1. Dmitry Grebeniuk
  2. parvel

Source

parvel / typeinfo.ml

module Registry
 :
  sig
    type utypeinfo = private string  (* physically unique *);
    value make_utypeinfo : string -> utypeinfo;
  end
 =
  struct
    type utypeinfo = string;
    type info = unit;
    value tbl = Hashtbl.create 17;
    value info : info = ();
    value make_utypeinfo type_name =
      let type_name = String.copy type_name in
      if Hashtbl.mem tbl type_name
      then
        failwith (Printf.sprintf "Typeinfo.make_typeinfo: type %S \
                    is already registered" type_name)
      else
        ( Hashtbl.add tbl type_name info
        ; type_name
        )
    ;
  end
;


(* "информация о типе"
   фиксированного типа
   стрелки "от" пока не нарисованы,
   стрелки "к" -- проекции [ttypeinfo 'a] *)
type utypeinfo = Registry.utypeinfo
;


(* "информация о типе"
   параметризовано типом *)
type ttypeinfo 'a =
  { tti_uti : utypeinfo
  ; tti_temp_contents : mutable option (tbox 'a)
  ; tti_json : mutable option
      ( ('a -> Json_type.t) * (Json_type.t -> 'a) )
  }
and
(* значение в ящике
   параметризовано типом *)
tbox 'a =
  { tb_val : 'a
  ; tb_tti : ttypeinfo 'a
  }
;


(* взять нетипизированную "информацию о типе" из типизированной: *)
value utypeinfo : ttypeinfo 'a -> utypeinfo
= fun tti ->
  tti.tti_uti
;


(* значение в ящике
   фиксированного типа *)
type ubox =
  { ub_store : !'a . ttypeinfo 'a -> unit
  ; ub_uti : utypeinfo
  }
;


value uti_type_name : utypeinfo -> string
= fun x -> (x : utypeinfo :> string)
;


(* засовываем значение в типизированный ящик
   требуется "информация о типе" *)
value tput : ttypeinfo 'a -> 'a -> tbox 'a
= fun tti a ->
  { tb_val = a
  ; tb_tti = tti
  }
;


(* берём значение из типизированного ящика
   тривиально *)
value tget : tbox 'a -> 'a
= fun tb ->
  tb.tb_val
;


(* стираем тип ящика
   тривиально *)
value ubox : tbox 'a -> ubox
= fun tb ->
  let tb_opt = Some tb
  and tti = tb.tb_tti
  in
  { ub_store = fun _ -> tti.tti_temp_contents := tb_opt
  ; ub_uti = tb.tb_tti.tti_uti
  }
;


(* arguments: (expected, got) *)
exception Type_error of string and string
;


value () = Printexc.register_printer (fun
  [ Type_error expected got -> Some (Printf.sprintf
      "expected type %S, got type %S"
      expected got)
  | _ -> None
  ]
)
;


(* добавляем тип ящику
   требуется "информация о типе"
   может обломаться
*)
value tbox_exn : ttypeinfo 'a -> ubox -> tbox 'a
= fun tti ub ->
  if ub.ub_uti == tti.tti_uti
  then
    let () = ub.ub_store tti in
    let aopt = tti.tti_temp_contents in
    let () = tti.tti_temp_contents := None in
    (* если aopt=None, то внутренняя ошибка:
       одинаковое uti, разные ref cells *)
    match aopt with
    [ None -> assert False
    | Some a -> a
    ]
  else
    raise (Type_error (uti_type_name tti.tti_uti) (uti_type_name ub.ub_uti))
;


value uget_exn : ttypeinfo 'a -> ubox -> 'a
= fun tti ub ->
  tget (tbox_exn tti ub)
;


(* добавляем тип ящику
   требуется "информация о типе"
   может обломаться
*)
value tbox_opt : ttypeinfo 'a -> ubox -> option (tbox 'a)
= fun tti ub ->
  try
    Some (tbox_exn tti ub)
  with
  [ _ -> None ]
;


value uget_opt : ttypeinfo 'a -> ubox -> option 'a
= fun tti ub ->
  try
    Some (uget_exn tti ub)
  with
  [ _ -> None ]
;


module IO = Parvel_IO
;

(* взять значение из ящика в IO-монаде
   требуется "информация о типе"
   может обломаться с ошибкой IO-монады
*)
value uget_io : ttypeinfo 'a -> ubox -> IO.m 'a
= fun tti ub ->
  try
    IO.return (uget_exn tti ub)
  with
  [ e -> IO.error e ]
;


(*****************************************************)


(* [make_typeinfo "имятипа"] создаёт "информацию о типе".
   имя типа должно быть уникально в пределах программы
   (при необходимости используйте иерархию) *)
value make_typeinfo : string -> ttypeinfo 'a
= fun type_name ->
  let uti = Registry.make_utypeinfo type_name in
  { tti_uti = uti
  ; tti_temp_contents = None
  ; tti_json = None
  }
;


(* добавление [де]сериализаций будет осуществляться
   функциями, изменяющими {t,u}typeinfo (добавляющими
   способы [де]сериализации).  Например, в
   "фиксированный тип", как в случае json, слегка ниже. *)


(* добавить к "информации о типе" сериализацию в/из json.
   Ошибки десериализации, кинутые в виде исключений
   функцией "из json в 'a", должны обрабатываться как
   "не шмогла", как и для других случаев (например, как
   для неправильно-подсунутой [ttypeinfo 'a] при
   преобраовании [ubox] в [tbox 'b]). *)


value ti_json :
  ttypeinfo 'a ->
  ('a -> Json_type.t) ->
  (Json_type.t -> 'a) ->
  unit
= fun tti to_json of_json ->
  tti.tti_json := Some (to_json, of_json)
;


(* засунуть json согласно данного [utypeinfo]: *)
value uput_json : utypeinfo -> Json_type.t -> ubox
= fun uti j ->
  { ub_store = fun tti ->
      match tti.tti_json with
      [ None -> failwith (Printf.sprintf
          "json deserialization to type %S is not supported"
          (uti_type_name tti.tti_uti)
        )
      | Some (_to_json, of_json) ->
          tti.tti_temp_contents :=
            Some
              { tb_val = of_json j  (* ошибка в виде исключения идёт вверх *)
              ; tb_tti = tti
              }
      ]
  ; ub_uti = uti
  }
;


(* взять json из данного [tbox 'a]: *)
value tget_json : tbox 'a -> Json_type.t
= fun tb ->
  match tb.tb_tti.tti_json with
  [ None -> failwith (Printf.sprintf
      "json serialization of type %S is not supported"
      (uti_type_name tb.tb_tti.tti_uti)
    )
  | Some (to_json, _of_json) -> to_json tb.tb_val
  ]
;


(* взять имя типа данного [tbox 'a]: *)
value tget_type_name : tbox 'a -> string
= fun tb ->
  uti_type_name tb.tb_tti.tti_uti
;


(* взять имя типа из данного [tbox 'a]: *)
value tbox_type_name : tbox 'a -> string
= fun tb ->
  uti_type_name tb.tb_tti.tti_uti
;


(* взять имя типа из данного [ubox]: *)
value ubox_type_name : ubox -> string
= fun ub ->
  uti_type_name ub.ub_uti
;