Source file `capability.ml`

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
(*****************************************************************************)
(*                                                                           *)
(* SPDX-License-Identifier: MIT                                              *)
(* Copyright (c) 2025 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2026 Mathias Bourgoin <mathias.bourgoin@atacama.tech>       *)
(*                                                                           *)
(*****************************************************************************)

[@@@warning "-32-34-37-69"]

type 'a key = {id : int; name : string}

let next_id = ref 0

let fresh_id () =
  let v = !next_id in
  incr next_id ;
  v

let create ~name : 'a key = {id = fresh_id (); name}

module IntMap = Map.Make (Int)

let store : Obj.t IntMap.t ref = ref IntMap.empty

let names : string IntMap.t ref = ref IntMap.empty

let set (type a) (k : a key) (v : a) : unit =
  store :=
    IntMap.add
      k.id
      (Obj.repr v [@allow_forbidden "type-erased capability store"])
      !store ;
  names := IntMap.add k.id k.name !names

let register = set

let get (type a) (k : a key) : a option =
  match IntMap.find_opt k.id !store with
  | None -> None
  | Some o ->
      Some ((Obj.obj o : a) [@allow_forbidden "type-erased capability store"])

let require k =
  match get k with
  | Some v -> v
  | None ->
      let bt = try Printexc.get_backtrace () with _ -> "(no backtrace)" in
      failwith
        (Printf.sprintf "capability missing: %s\nbacktrace:\n%s" k.name bt)

let mem k = IntMap.mem k.id !store

let clear () =
  store := IntMap.empty ;
  names := IntMap.empty

let list () =
  let all =
    IntMap.fold
      (fun id name acc -> (name, IntMap.mem id !store) :: acc)
      !names
      []
  in
  List.rev all

type any = Any : 'a key -> any

let any k = Any k

let check_all lst =
  let missing = ref [] in
  List.iter
    (fun (Any k) -> if not (mem k) then missing := k.name :: !missing)
    lst ;
  List.rev !missing