Commits

Dmitry Grebeniuk  committed a8eb125

+ good type errors

  • Participants
  • Parent commits 7b9391b

Comments (0)

Files changed (2)

 ;
 
 
+value uti_type_name : utypeinfo -> string
+= fun x -> (x : utypeinfo :> string)
+;
+
+
 (* засовываем значение в типизированный ящик
    требуется "информация о типе" *)
 value tput : ttypeinfo 'a -> 'a -> tbox 'a
 ;
 
 
+(* 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 ->
-  if ub.ub_uti == tti.tti_uti
-  then
-    let () = ub.ub_store tti in
-    let a = tti.tti_temp_contents in
-    let () = tti.tti_temp_contents := None in
-    (* если a=None, то внутренняя ошибка: одинаковое uti, разные ref cells *)
-    a
-  else
-    None  (* ошибка: тип не соответствует по имени *)
+  try
+    Some (tbox_exn tti ub)
+  with
+  [ _ -> None ]
 ;
 
 
-(* композиция "tbox_opt;tget" *)
 value uget_opt : ttypeinfo 'a -> ubox -> option 'a
 = fun tti ub ->
-  match tbox_opt tti ub with
-  [ None -> None
-  | Some tb -> Some (tget tb)
-  ]
+  try
+    Some (uget_exn tti ub)
+  with
+  [ _ -> None ]
 ;
 
 
 *)
 value uget_io : ttypeinfo 'a -> ubox -> IO.m 'a
 = fun tti ub ->
-  match tbox_opt tti ub with
-  [ None -> IO.error (Failure "Parvel.Typeinfo.uget_io: bad types")
-  | Some tb -> IO.return (tget tb)
-  ]
+  try
+    IO.return (uget_exn tti ub)
+  with
+  [ e -> IO.error e ]
 ;
 
 
 = fun uti j ->
   { ub_store = fun tti ->
       match tti.tti_json with
-      [ None -> failwith "json deserialization is not supported"
+      [ 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 :=
-            try
-              Some
-                { tb_val = of_json j
-                ; tb_tti = tti
-                }
-            with
-            [ _ -> None ]  (* по-хорошему, ошибку бы надо сохранять *)
+            Some
+              { tb_val = of_json j  (* ошибка в виде исключения идёт вверх *)
+              ; tb_tti = tti
+              }
       ]
   ; ub_uti = uti
   }
 value tget_json : tbox 'a -> Json_type.t
 = fun tb ->
   match tb.tb_tti.tti_json with
-  [ None -> failwith "json serialization is not supported"
+  [ 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
   ]
 ;
 
 
-value uti_type_name : utypeinfo -> string
-= fun x -> (x : utypeinfo :> string)
-;
-
-
 (* взять имя типа данного [tbox 'a]: *)
 value tget_type_name : tbox 'a -> string
 = fun tb ->

File typeinfo.mli

    тривиально *)
 value ubox : tbox 'a -> ubox;
 
+(* arguments: (expected, got) *)
+exception Type_error of string and string;
 
 (* добавляем тип ящику
    требуется "информация о типе"
-   может обломаться, возвращая None
+   может обломаться, бросая исключение
 *)
-value tbox_opt : ttypeinfo 'a -> ubox -> option (tbox 'a);
+value tbox_exn : ttypeinfo 'a -> ubox -> tbox 'a;
 
 (* взять значение из ящика
    требуется "информация о типе"
-   может обломаться, возвращая None
+   может обломаться, бросая исключение
 *)
-value uget_opt : ttypeinfo 'a -> ubox -> option 'a;
+value uget_exn : ttypeinfo 'a -> ubox -> 'a;
 
 (* взять значение из ящика в IO-монаде
    требуется "информация о типе"
    может обломаться с ошибкой IO-монады
-   (пока -- [Failure _], потом -- что-то более конкретное)
 *)
 value uget_io : ttypeinfo 'a -> ubox -> Parvel_IO.m 'a;