Source file `caml_embed.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
open! Core
open! Import
module Id = Caml_embedded_id

type t = Value.t [@@deriving sexp_of]

external ecaml_inject : Id.t -> t = "ecaml_inject"
external ecaml_project : t -> Id.t = "ecaml_project"

let ecaml_project t =
  try ecaml_project t with
  | exn ->
    let name = "[Caml_embed.ecaml_project]" in
    raise_s
      (match exn with
       | Failure message -> [%message (concat [ name; ": "; message ]) ~_:(t : t)]
       | _ -> [%message name ~_:(exn : exn) ~_:(t : t)])
;;

let embedded_values = Id.Table.create ()

let create type_id v =
  let id = Id.create () in
  Hashtbl.set embedded_values ~key:id ~data:(Univ.create type_id v);
  ecaml_inject id
;;

let lookup_by_id_exn id type_id =
  let univ = Hashtbl.find_exn embedded_values id in
  Univ.match_exn univ type_id
;;

let extract_exn t type_id =
  let id = ecaml_project t in
  lookup_by_id_exn id type_id
;;

let to_value = Fn.id

let of_value_exn v =
  let id = ecaml_project v in
  if Hashtbl.mem embedded_values id
  then v
  else failwith "Ecaml value doesn't represent ocaml embedded value"
;;

let () =
  Ecaml_callback.(register free_embedded_caml_values)
    [%here]
    ~f:(fun ids -> Array.iter ids ~f:(fun id -> Hashtbl.remove embedded_values id))
    ~should_run_holding_async_lock:true
;;

let debug_sexp () = [%sexp_of: Univ.t Id.Table.t] embedded_values

let create_type (type_id : _ Type_equal.Id.t) =
  Value.Type.create
    [%message "caml_embed" ~type_id:(Type_equal.Id.name type_id : string)]
    (Type_equal.Id.to_sexp type_id)
    (fun v ->
       let embed = of_value_exn v in
       extract_exn embed type_id)
    (fun a -> create type_id a |> to_value)
;;