Commits

Anonymous committed 739e267

ocaml_conv bug fixes

Comments (0)

Files changed (4)

+1.2.0 (just a plan)
+--------------------
+
+- (To be done) poly_variant decoder now takes an option of value instead of a list of values
+
 1.1.4 (not yet)
 -------------
 
 - Added xml_conv
 - Added ref converters
+- Bug fixes of ocaml_conv
 
 1.1.3
 -------------
   | Object of (string * t) list
   | Tuple of t list
   | Unit
+(*
   | Let_rec of string * t * t
   | Var of string
+*)
 
 type ocaml = t
 
     | Char c -> f ppf "%C" c
     | String s -> if raw_string then f ppf "\"%s\"" s else f ppf "%S" s
     | List [] -> f ppf "[]"
-    | List ts -> f ppf "[ @[%a@] ]" (format_list ";@ " format) ts
+    | List ts -> f ppf "[ @[<hv>%a@] ]" (format_list ";@ " format) ts
     | Array ts -> f ppf "[ @[%a@] ]" (format_list ";@ " format) ts
     | Variant ("::", [hd;tl]) -> f ppf "@[<2>(%a@ :: %a)@]" format hd format tl
     | Variant (tag, []) -> f ppf "%s" tag
-    | Variant (tag, [t]) -> f ppf "@[<2>%s@ @[%a@]@]" tag format t
+    | Variant (tag, [t]) -> f ppf "@[<2>%s@ (@[%a@])@]" tag format t
     | Variant (tag, ts) -> f ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
     | Poly_variant (tag, [])  when no_poly -> f ppf "%s" tag
-    | Poly_variant (tag, [t]) when no_poly -> f ppf "@[<2>%s@ @[%a@]@]" tag format t
+    | Poly_variant (tag, [t]) when no_poly -> f ppf "@[<2>%s@ (@[%a@])@]" tag format t
     | Poly_variant (tag, ts)  when no_poly -> f ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
     | Poly_variant (tag, []) -> f ppf "`%s" tag
     | Poly_variant (tag, [t]) -> f ppf "@[<2>`%s@ @[%a@]@]" tag format t
     | Poly_variant (tag, ts) -> f ppf "@[<2>`%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
-    | Record fields -> f ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (fi, v) -> f ppf "%s= %a" fi format v)) fields
-    | Object fields when no_poly -> f ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (fi, v) -> f ppf "%s= %a" fi format v)) fields
-    | Object fields -> f ppf "@[@[<2>object@,@[%a@]@]@,end@]" (format_list "@ " (fun ppf (fi, v) -> f ppf "method %s= %a" fi format v)) fields
-    | Tuple ts -> f ppf "(@[%a@])" (format_list ",@ " format) ts
+    | Record fields -> f ppf "@[<2>{ @[<hv>%a@] }@]" (format_list ";@ " (fun ppf (fi, v) -> f ppf "@[<2>%s=@ %a@]" fi format v)) fields
+    | Object fields when no_poly -> f ppf "@[<2>{ @[<hv>%a@] }@]" (format_list ";@ " (fun ppf (fi, v) -> f ppf "@[<2>%s=@ %a@]" fi format v)) fields
+    | Object fields -> f ppf "@[@[<2>object@,@[<hv>%a@]@]@,end@]" (format_list "@ " (fun ppf (fi, v) -> f ppf "method %s= %a" fi format v)) fields
+    | Tuple ts -> f ppf "(@[<hv>%a@])" (format_list ",@ " format) ts
     | Unit -> f ppf "()"
+(*
     | Var s -> pp_print_string ppf s
     | Let_rec (s, t1, t2) -> f ppf "@[@[<2>let rec %s = %a in@]@ %a@]" s format t1 format t2
+*)
   in
   format ppf v
 
   type error = [ `Invalid_construct of Location.t
                | `Lexer of Location.t * Lexer.error
                | `Parser of Syntaxerr.error
+	       | `Syntax_error of Location.t
                | `Exn of exn ]
 
   exception Error of error
         | Expecting (loc, _) -> loc
         | Other loc -> loc
         end
+    | `Syntax_error loc -> loc
     | `Exn _ -> Location.none
 
   let format_error ppf e = 
     | `Exn exn  -> f ppf "exn: %s" (Printexc.to_string exn)
     | `Lexer (_loc, e)  -> f ppf "lexer error: %a"  Lexer.report_error e
     | `Parser e -> f ppf "parser error: %a" Syntaxerr.report_error e
+    | `Syntax_error _loc -> f ppf "syntax error"
 
   let () = Printexc.register_printer (function
     | Error e -> Some (format_sprintf "%a" format_error e)
     | Pexp_object class_str ->
         (* Ignores class_str.pcstr_pat *)
         object_ class_str.pcstr_fields
+(*
     | Pexp_let (Recursive, [ {ppat_desc = Ppat_var {txt = s}}, e1], e2) -> Let_rec (s, expression e1, expression e2)
     | Pexp_ident {txt = Longident.Lident s } -> Var s
+*)
     | _ -> invalid e.pexp_loc
 
   and constant = function
 
   and construct loc lident argopt =
     let name = strip loc lident in
-    match argopt with
-    | None -> Variant (name, [])
-    | Some {pexp_desc= Pexp_tuple es; _} -> Variant (name, List.map expression es)
-    | Some e -> Variant (name, [expression e])
+    match argopt, name with
+    | None, "true" -> Bool true
+    | None, "false" -> Bool false
+    | None, _ -> Variant (name, [])
+    | Some {pexp_desc= Pexp_tuple es; _}, _ -> Variant (name, List.map expression es)
+    | Some e, _ -> Variant (name, [expression e])
 
   let from_lexbuf lexbuf = 
     try
     | (Error _ as exn) -> raise exn
     | Lexer.Error (e, loc) -> raise (Error (`Lexer (loc, e)))
     | Syntaxerr.Error e -> raise (Error (`Parser e))
+
+    | Parsing.Parse_error | Syntaxerr.Escape_error ->
+      let loc = Location.curr lexbuf in
+      raise (Error (`Syntax_error loc))
     | e -> exn e
 
   let from f d = from_lexbuf (f d)
   let from_function = from Lexing.from_function
 end
 
-type load_error = [ `Conv of t Meta_conv.Error.t
-                  | `Exn of exn
-                  | `Invalid_construct of Location.t
-                  | `Lexer of Location.t * Lexer.error
-                  | `Parser of Syntaxerr.error ]
+type load_error = [ `Conv of t Meta_conv.Error.t | Parser.error ]
 
 let format_load_error ppf = function
   | `Conv e -> Meta_conv.Error.format (format ~no_poly:false ~raw_string:false) ppf e
   | Object of (string * t) list
   | Tuple of t list
   | Unit
+(*
   | Let_rec of string * t * t
   | Var of string
+*)
 
 type ocaml = t
 
   type error = [ `Invalid_construct of Location.t
                | `Lexer of Location.t * Lexer.error
                | `Parser of Syntaxerr.error
+	       | `Syntax_error of Location.t
                | `Exn of exn ]
 
   exception Error of error
   val from_function : (string -> int -> int) -> t list
 end
 
-type load_error = [ `Conv of t Meta_conv.Error.t
-                  | `Exn of exn
-                  | `Invalid_construct of Location.t
-                  | `Lexer of Location.t * Lexer.error
-                  | `Parser of Syntaxerr.error ]
+type load_error = [ `Conv of t Meta_conv.Error.t | Parser.error ]
 
 val format_load_error : Format.formatter -> load_error -> unit
 

ocaml/ocaml_conv.ml

       | _ -> failwith "Variant expected for variant"
 
     let poly_variant _tyname = function 
-      | Variant (tag, ts) -> tag, ts
-      | Poly_variant (tag, ts) -> tag, ts
+      | Variant (tag, []) -> tag, []
+      | Poly_variant (tag, []) -> tag, []
+      | Variant (tag, [t]) -> tag, [t]
+      | Poly_variant (tag, [t]) -> tag, [t]
+      | Variant (tag, ts) -> tag, [Tuple ts]
+      | Poly_variant (tag, ts) -> tag, [Tuple ts]
       | _ -> failwith "Poly_variant expected for poly_variant"
 
     let record _tyname = function
   
 let bool_of_ocaml = Helper.of_deconstr (function
   | Bool b -> b
-  | _ -> failwith "bool_of trace: Bool expected")
+  | v -> Printf.ksprintf failwith "bool_of_ocaml trace: Bool expected (%s)" 
+	Obj.(let o = repr v in
+	     if is_int o then Printf.sprintf "int=%d" (Obj.obj o)
+	     else Printf.sprintf "tag=%d" (tag o)))
 
 let string_of_ocaml = Helper.of_deconstr (function
   | String s -> s
 let option_of_ocaml f = Helper.option_of (function
   | Variant ("None", []) -> Some None 
   | Variant ("Some", [v]) -> Some (Some v)
+  | Variant ("Some", vs) -> Some (Some (Tuple vs))
   | _ -> None) f
 
 let ref_of_ocaml f = Helper.ref_of (function