Commits

Anonymous committed ded26ec

.

  • Participants
  • Parent commits 05848c8

Comments (0)

Files changed (2)

 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
 (* значение в ящике
 (* значение в ящике
    фиксированного типа *)
 type ubox =
-  { ub_store : unit -> unit
+  { ub_store : !'a . ttypeinfo 'a -> unit
   ; ub_uti : utypeinfo
   }
 ;
   let tb_opt = Some tb
   and tti = tb.tb_tti
   in
-  { ub_store = fun () -> tti.tti_temp_contents := tb_opt
+  { ub_store = fun _ -> tti.tti_temp_contents := tb_opt
   ; ub_uti = tb.tb_tti.tti_uti
   }
 ;
 = fun tti ub ->
   if ub.ub_uti == tti.tti_uti
   then
-    let () = ub.ub_store () in
+    let () = ub.ub_store tti in
     let a = tti.tti_temp_contents in
     let () = tti.tti_temp_contents := None in
     a
   let uti = Registry.make_utypeinfo type_name in
   { tti_uti = uti
   ; tti_temp_contents = None
+  ; tti_json = None
   }
 ;
 
    "фиксированный тип", как в случае json, слегка ниже. *)
 
 
-(*********
-
 (* добавить к "информации о типе" сериализацию в/из json.
    Ошибки десериализации, кинутые в виде исключений
    функцией "из json в 'a", должны обрабатываться как
   (Json_type.t -> 'a) ->
   unit
 = fun tti to_json of_json ->
-  .
-
-to_json использует ту же дырку для сохранения временного, и
-ub_store использует to_json переданный в композиции с присвоением.
-
-
+  tti.tti_json := Some (to_json, of_json)
 ;
 
 
-(* засунуть json согласно данного [ttypeinfo 'a]: *)
-value put_json : utypeinfo -> Json_type.t -> ubox
-= 
+(* засунуть json согласно данного [utypeinfo]: *)
+value uput_json : utypeinfo -> Json_type.t -> ubox
+= fun uti j ->
+  { ub_store = fun tti ->
+      match tti.tti_json with
+      [ None -> failwith "json deserialization is not supported"
+      | Some (_to_json, of_json) ->
+          tti.tti_temp_contents :=
+            try
+              Some
+                { tb_val = of_json j
+                ; tb_tti = tti
+                }
+            with
+            [ _ -> None ]  (* по-хорошему, ошибку бы надо сохранять *)
+      ]
+  ; ub_uti = uti
+  }
 ;
 
 
 (* взять json из данного [tbox 'a]: *)
-value get_json : tbox 'a -> Json_type.t;
-
-
-**************)
+value tget_json : tbox 'a -> Json_type.t
+= fun tb ->
+  match tb.tb_tti.tti_json with
+  [ None -> failwith "json serialization is not supported"
+  | Some (to_json, _of_json) -> to_json tb.tb_val
+  ]
+;

File typeinfo.mli

    “фиксированный тип”, как в случае json, слегка ниже. *)
 
 
-(************
-
 (* добавить к “информации о типе” сериализацию в/из json.
    Ошибки десериализации, кинутые в виде исключений
    функцией “из json в 'a”, должны обрабатываться как
   unit;
 
 
-(* засунуть json согласно данного [ttypeinfo 'a]: *)
-value tput_json : ttypeinfo 'a -> Json_type.t -> tbox 'a;
+(* засунуть json согласно данного [utypeinfo] в [ubox]: *)
+value uput_json : utypeinfo -> Json_type.t -> ubox;
 
 
 (* взять json из данного [tbox 'a]: *)
-value get_json : tbox 'a -> Json_type.t;
-
-
-**********)
+value tget_json : tbox 'a -> Json_type.t;