Commits

camlspotter committed 24ebba8

exn fix

  • Participants
  • Parent commits 4ede7f1

Comments (0)

Files changed (5)

json/json_conv.ml

     | _ -> failwith "Object expected for record"
 end)
 
-exception Error of Json.t error * Address.t
+exception Error of Json.t error
 
 type 'a decoder = ('a, Json.t) Meta_conv.Conv.decoder
 
 let errorf v adrs fmt = 
-  kprintf (fun s -> `Error (Primitive_decoding_failure (s, v), adrs)) fmt
+  kprintf (fun s -> `Error (Primitive_decoding_failure s, v, adrs)) fmt
 
 let string_of_json ?(adrs=Address.top) = function
   | String s -> `Ok s

json/json_conv.mli

   val record : Json.t * Address.t -> (string * (Json.t * Address.t)) list
 end
 
-exception Error of Json.t error * Address.t
+exception Error of Json.t error
 
 type 'a decoder = ('a, Json.t) Meta_conv.Conv.decoder
 
 
 
 (** Decoding may fail *)
-type 'target error = 
-  | Deconstruction_error of exn * 'target
+type 'target error_desc = 
+  | Deconstruction_error of exn
   | Unknown_fields of string * (string * 'target) list
     (** listed fields in target record have no corresponding OCaml record fields *)
   | Required_fields_not_found of string * string list * (string * 'target) list
     (** required record fields are not found in the target value *)
-  | Wrong_arity of int (** expected *) * int (** actual *) * (string * string) option * 'target
-  | Primitive_decoding_failure of string * 'target
+  | Wrong_arity of int (** expected *) * int (** actual *) * (string * string) option
+  | Primitive_decoding_failure of string
+
+type 'target error = 'target error_desc * 'target * Address.t
 
 type ('host, 'target) result = 
   [ `Ok of 'host 
-  | `Error of 'target error * Address.t 
+  | `Error of 'target error
   ]
 
 type ('host, 'target) decoder = ?adrs: Address.t -> 'target -> ('host, 'target) result
 
 let bind t f = match t with
   | `Ok v -> f v
-  | `Error (err, adrs) -> `Error (err, adrs)
+  | `Error (err, v, adrs) -> `Error (err, v, adrs)
 
 let (>>=) = bind
 
 let fmap f t = match t with
   | `Ok v -> `Ok (f v)
-  | `Error (err, adrs) -> `Error (err, adrs)
+  | `Error (err, v, adrs) -> `Error (err, v, adrs)
 
 let mapM : ('a, 'target) decoder -> ('target * Address.t) list -> ('a list, 'target) result
 = fun d xs ->
 external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 
 let tuple_arity_error exp_len act_len v adrs = 
-  `Error (Wrong_arity (exp_len, act_len, None, v), adrs)
+  `Error (Wrong_arity (exp_len, act_len, None), v, adrs)
 let variant_arity_error type_name constructor_name exp_len act_len v adrs = 
-  `Error (Wrong_arity (exp_len, act_len, Some (type_name, constructor_name), v), adrs)
+  `Error (Wrong_arity (exp_len, act_len, Some (type_name, constructor_name)), v, adrs)
 let variant_unknown_tag_error type_name tag_name v adrs =
-  `Error (Unknown_fields (type_name, [ tag_name, v ]), adrs) 
+  `Error (Unknown_fields (type_name, [ tag_name, v ]), v, adrs) 
+(*
 let record_unknown_fields_error type_name v adrs =
   `Error (Unknown_fields (type_name, v), adrs) 
+*)
 let primitive_decoding_failure mes v adrs = 
-  `Error (Primitive_decoding_failure (mes, v), adrs)
+  `Error (Primitive_decoding_failure mes, v, adrs)
 
-let field_assoc name key alist adrs (decode : (_,_) decoder) =
+let field_assoc name v adrs key alist (decode : (_,_) decoder) =
   try 
     let (v, adrs) = List.assoc key alist in
     decode ~adrs v
-  with Not_found -> `Error (Required_fields_not_found (name, [key], 
-                                                       List.map (fun (k,(t,_a)) -> k,t) alist), 
-                            adrs)
+  with Not_found -> 
+    `Error (Required_fields_not_found (name, [key], 
+                                       List.map (fun (k,(t,_a)) -> k,t) alist), 
+            v, adrs)
 
 let filter_record_fields type_system actual =
   List.filter (fun (f,_) -> not (List.mem f type_system)) actual 
 
-type ('b, 'a) field_checker =
+type ('host, 'target) field_checker =
     string (** type name *)
-    -> (string * ('a * Address.t)) list (** unknown fields *)
+    -> 'target (** the input *)
     -> Address.t 
-    -> (unit -> ('b, 'a) result) 
-    -> ('b, 'a) result
+    -> (string * ('target * Address.t)) list (** unknown fields *)
+    -> (unit -> ('host, 'target) result) 
+    -> ('host, 'target) result
 
-let record_unknown_field_check name unknowns adrs k = match unknowns with
+let record_unknown_field_check name v adrs unknowns k = match unknowns with
   | [] -> k ()
-  | _ -> `Error (Unknown_fields (name, List.map (fun (k, (v,_a)) -> k,v) unknowns), adrs)
+  | _ -> `Error (Unknown_fields (name, List.map (fun (k, (v,_a)) -> k,v) unknowns), v, adrs)
 
-let record_ignore_unknown_fields _name _unknons _adrs k = k ()
+let record_ignore_unknown_fields _name _v _adrs _unknons k = k ()
 
 let integer_of_float min max conv n =
   if floor n <> n then `Error "not an integer"
   val record  : (t * Address.t) -> (string * (t * Address.t)) list
 end
 
-type 'target error =
+type 'target error_desc =
   | Deconstruction_error of 
       exn (** exception of the Decode.tuple, variant or record *)
-      * 'target (** the input *)
   | Unknown_fields of 
       string (** type name *) 
       * (string * 'target) list (** unknown fields *)
       int (** expected *) 
       * int (** actual *) 
       * (string * string) option (** type name and tag, if tuple, None *) 
-      * 'target (** the input *)
   | Primitive_decoding_failure of 
       string (** message *)
-      * 'target (** the input *)
+
+type 'target error = 'target error_desc * 'target * Address.t
 
 type ('host, 'target) result =
   [ `Ok of 'host 
-  | `Error of 'target error * Address.t 
+  | `Error of 'target error
   ]
 
 type ('host, 'target) decoder = ?adrs: Address.t -> 'target -> ('host, 'target) result
 
 val field_assoc : 
   string  (** type name *)
+  -> 'target (** the value *)  
+  -> Address.t
   -> string  (** field name *)
   -> (string * ('target * Address.t)) list  (** record *)
-  -> Address.t
   -> ('host, 'target) decoder (** converter *)
   -> ('host, 'target) result
 
 
 type ('host, 'target) field_checker =
     string (** type name *)
+    -> 'target (** the input *)
+    -> Address.t 
     -> (string * ('target * Address.t)) list (** unknown fields *)
-    -> Address.t 
     -> (unit -> ('host, 'target) result) 
     -> ('host, 'target) result
 
   string -> string -> int -> int (** actual *) -> 'target -> Address.t -> ('host, 'target) result
 val variant_unknown_tag_error :
   string -> string -> 'target -> Address.t -> ('host, 'target) result
+(*
 val record_unknown_fields_error :
     string -> (string * 'target) list -> Address.t -> ('host, 'target) result
+*)
 val primitive_decoding_failure :
   string (** message *)
   -> 'target (** the input *)

pa/pa_meta_conv.ml

       case
     in
     let default = <:match_case<
-      name, l -> Meta_conv.Conv.variant_unknown_tag_error $str:name$ name __value __address
+      name, l -> 
+        Meta_conv.Conv.variant_unknown_tag_error 
+          $str:name$ name __value __address
       >>
     in
     let cases = 
               let conv = gen_ctyp ctyp in
               name :: labs,
               (lab_id, 
-               <:expr< Meta_conv.Conv.field_assoc $str:ty_name$ $str:name$ fields __address $conv$ >>)
+               <:expr< Meta_conv.Conv.field_assoc $str:ty_name$ __value __address $str:name$ fields $conv$ >>)
               :: st, 
               rest
           | Some (Tag_name name) -> 
               let conv = gen_ctyp ctyp in
               name :: labs,
               (lab_id, 
-               <:expr< Meta_conv.Conv.field_assoc $str:ty_name$ $str:name$ fields __address $conv$ >>)
+               <:expr< Meta_conv.Conv.field_assoc $str:ty_name$ __value __address $str:name$ fields $conv$ >>)
               :: st,
               rest
           | Some The_rest_in_raw when rest = None -> 
       let valid_labels = $labels$ in
       let fields = $id:module_path$.Decode.record (__value, __address) in 
       let unknown_fields = Meta_conv.Conv.filter_record_fields valid_labels fields in
-      $unknown_fields_check$ $str:ty_name$ unknown_fields __address (fun () -> 
+      $unknown_fields_check$ $str:ty_name$ __value __address unknown_fields (fun () -> 
         $the_record$) 
     >>
     
           fun ?adrs v -> 
             match $ Gen.apply _loc <:expr< $lid: name ^ "_of_" ^ A.conv_name$ >> (List.map expr_of_tvar params)$ ?adrs v with
             | `Ok v -> v
-            | `Error (e, adrs) -> raise ($id:module_path$.Error (e, adrs))
+            | `Error (e, v, adrs) -> raise ($id:module_path$.Error (e, v, adrs))
         >> $
     >>