Commits

camlspotter committed d935179 Merge

merged with default

  • Participants
  • Parent commits 5791947, 38a7e20
  • Branches 0.11.0

Comments (0)

Files changed (28)

 0.11.0
 -------------
 
-- Bug fixes
+- Added (partial) polymorphic variant and object type support
+
 - Removed Address.t, since it just complicates the code base.
   Tree addresses must be handled by the tree data themselves.
 
+- Removed (: Leftovers :) annotation. Use mc_leftovers special type instead.
+
+- [t mc_leftovers] can live with more than one conv()s. 
+  [t mc_leftovers] works as leftover fields only for a conv(type) with the same
+  syntactic target type. For example, [Json.t mc_leftovers] works as leftover field
+  for conv(json), but not for conv(ocaml).
+
+- ocaml_conv now has parser by compiler-libs
+
+- Bug fixes
+
 0.10.0
 -------------
 
 Limitations 
 ------------------
 
-Polymorphic variants, classes and GADTs are not supported.
+Open polymorphic variants, classes and GADTs are not supported.
 
 Modules and values to be accessible
 -------------------------------------
           module Encode : sig
             val tuple : t list -> t
             val variant : string -> t list -> t
+            val poly_variant : string -> t list -> t
             val record : (string * t) list -> t
           end
         
             (* Address.t = Meta_conv.Internal.Address.t *)
             val tuple   : (t * Address.t) -> (t * Address.t) list
             val variant : (t * Address.t) -> string * (t * Address.t) list
+            val poly_variant : (t * Address.t) -> string * (t * Address.t) list
             val record  : (t * Address.t) -> (string * (t * Address.t)) list
           end
         end

File json/json_conv.ml

     | [] -> String tag
     | ts -> Object [tag, Array ts]
   let record tag_ts  = Object tag_ts
+  let poly_variant = variant
 end
 
 let json_of_int n       = Number (float n)
   let record = function
     | Object alist -> alist
     | _ -> failwith "Object expected for record"
+
+  let poly_variant = variant
 end
 
 exception Error of Json.t Error.t
   f
 
 let lazy_t_of_json d = generic_lazy_t_of (fun e -> raise (Error e)) d
-let mc_lazy_t_of_json = generic_mc_lazy_t_of
+let mc_lazy_t_of_json (d : 'a decoder) = (generic_mc_lazy_t_of d : ('a, Json.t) mc_lazy_t decoder)
 
 let json_of_mc_fields enc xs = Object (List.map (fun (name, a) -> (name, enc a)) xs)
 let mc_fields_of_json dec = generic_mc_fields_of (function Object js -> Some js | _ -> None) dec

File json/json_conv.mli

 module Encode : sig
   val tuple : Json.t list -> Json.t
   val variant : string -> Json.t list -> Json.t
+  val poly_variant : string -> Json.t list -> Json.t
   val record : Json.obj -> Json.t
 end
 
 module Decode : sig
   val tuple   : Json.t -> Json.t list
   val variant : Json.t -> string * Json.t list
+  val poly_variant : Json.t -> string * Json.t list
   val record  : Json.t -> (string * Json.t) list
 end
 
 val mc_lazy_t_of_json : 'a decoder -> ('a, Json.t) mc_lazy_t decoder
 
 val json_of_mc_fields : ('a -> Json.t) -> (string * 'a) list -> Json.t
-val mc_fields_of_json : ('a, Json.t) Decoder.t -> Json.t -> ((string * 'a) list, Json.t) Result.t
+val mc_fields_of_json : ('a, Json.t) Decoder.t -> Json.t -> ((string * 'a) list, Json.t Error.t) Result.t

File json/tests/test.ml

 end
 
 module Test6 = struct
-  type t = { x : int; y : float; rest (:Leftovers:) : Json.t mc_fields; } with conv (json)
+  type t = { x : int; y : float; rest : Json.t mc_leftovers; } with conv (json)
   type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (json)
   
   let () = 
     assert (t_of_json (json_of_t v) = `Ok v)
 end
 
+module Test8 = struct
+
+  type t = Foo 
+
+  and ts = t list with conv(json)
+
+end
+
+module Test9 = struct
+
+  type t = { x : int; y : float; z : t }
+
+  and ts = t list with conv(json)
+
+end

File lib/internal.ml

   module Encode : sig
     val tuple : t list -> t
     val variant : string -> t list -> t
+    val poly_variant : string -> t list -> t
     val record : (string * t) list -> t
+    val object_ : (string * t) list -> t
   end
 
   module Decode : sig
     val tuple   : t -> t list
     val variant : t -> string * t list
+    val poly_variant : t -> string * t list
     val record  : t -> (string * t) list
+    val object_ : t -> (string * t) list
   end
 end
 
-external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
-
 let tuple_arity_error exp_len act_len v = 
   `Error (Wrong_arity (exp_len, act_len, None), v)
 let variant_arity_error type_name constructor_name exp_len act_len v = 
     string (** type name *)
     -> 'target (** the input *)
     -> (string * 'target) list (** unknown fields *)
-    -> (unit -> ('host, 'target) Result.t) 
-    -> ('host, 'target) Result.t
+    -> (unit -> ('host, 'target Error.t) Result.t) 
+    -> ('host, 'target Error.t) Result.t
 
 let record_unknown_field_check name v unknowns k = match unknowns with
   | [] -> k ()
   else if min <= n && n <= max then `Ok (conv n)
   else `Error "overflow"
 
-let add_addresses base xs = 
-  List.fold_left (fun (i,rev_xs) x ->
-    (i+1, (x, i::base) :: rev_xs)) (0, []) xs
-  |> snd 
-  |> List.rev
-
 let generic_list_of gets d v = match gets v with
   | Some xs -> Result.map d xs
   | None -> 
   | None -> primitive_decoding_failure "mc_fields expected" target
   | Some fields ->
       map (fun (name, target) -> f target >>= fun host -> `Ok (name, host)) fields
+
+let list_filter_map f xs = List.fold_right (fun x st -> 
+  match f x with
+  | None -> st
+  | Some v -> v::st) xs []

File lib/internal.mli

   module Encode : sig
     val tuple   : t list -> t
     val variant : string -> t list -> t
+    val poly_variant : string -> t list -> t
     val record  : (string * t) list -> t
+    val object_ : (string * t) list -> t
   end
 
   module Decode : sig
     val tuple   : t -> t list
     val variant : t -> string * t list
+    val poly_variant : t -> string * t list
     val record  : t -> (string * t) list
+    val object_ : t -> (string * t) list
   end
 end
 
   -> string  (** field name *)
   -> (string * 'target) list  (** record *)
   -> ('host, 'target) Decoder.t (** converter *)
-  -> ('host, 'target) Result.t
+  -> ('host, 'target Error.t) Result.t
 
 val field_assoc_optional : 
   string  (** type name *)
   -> string  (** field name *)
   -> (string * 'target) list  (** record *)
   -> ('host, 'target) Decoder.t (** converter *)
-  -> ('host option, 'target) Result.t
+  -> ('host option, 'target Error.t) Result.t
 
 val filter_record_fields : 
   string list (** fields unkown in the type system *) 
     string (** type name *)
     -> 'target (** the input *)
     -> (string * 'target) list (** unknown fields *)
-    -> (unit -> ('host, 'target) Result.t) 
-    -> ('host, 'target) Result.t
+    -> (unit -> ('host, 'target Error.t) Result.t) 
+    -> ('host, 'target Error.t) Result.t
 
 val record_unknown_field_check : ('host, 'target) field_checker
 val record_ignore_unknown_fields : ('host, 'target) field_checker
 *)
 
 val tuple_arity_error : 
-  int -> int (** actual *) -> 'target -> ('host, 'target) Result.t
+  int -> int (** actual *) -> 'target -> ('host, 'target Error.t) Result.t
 val variant_arity_error :
-  string -> string -> int -> int (** actual *) -> 'target -> ('host, 'target) Result.t
+  string -> string -> int -> int (** actual *) -> 'target -> ('host, 'target Error.t) Result.t
 val variant_unknown_tag_error :
-  string -> string -> 'target -> ('host, 'target) Result.t
+  string -> string -> 'target -> ('host, 'target Error.t) Result.t
 (*
 val record_unknown_fields_error :
-    string -> (string * 'target) list -> Address.t -> ('host, 'target) Result.t
+    string -> (string * 'target) list -> Address.t -> ('host, 'target Error.t) Result.t
 *)
 val primitive_decoding_failure :
   string (** message *)
   -> 'target (** the input *)
-  -> ('host, 'target) Result.t
+  -> ('host, 'target Error.t) Result.t
 
 val integer_of_float : 
   float (** min value for the integer in float *)
   -> float (** max value for the integer in float *)
   -> (float -> 'a) (** conversion *)
   -> float (** to convert *)
-  -> [ `Ok of 'a | `Error of string ]
+  -> ('a, string) Result.t
 (** float to integer conversion with error checks *)
 
 val generic_list_of : 
 val generic_mc_lazy_t_of : 
   ('host, 'target) Decoder.t
   -> 'target
-  -> [> `Ok of ('host, 'target) Result.t lazy_t ]
+  -> [> `Ok of ('host, 'target Error.t) Result.t lazy_t ]
 (** typical mc_lazy_t_of_<targe_type> 
     The decoding is done lazily. 
     Error at the lazy decoding is reported by the result monad.
   ('target -> ('a * 'target) list option)
   -> ('host, 'target) Decoder.t
   -> 'target
-  -> (('a * 'host) list, 'target) Result.t
+  -> (('a * 'host) list, 'target Error.t) Result.t
+
+val list_filter_map : ('a -> 'b option) -> 'a list -> 'b list
+(** List.map + List.filter *)
 
 type 'a mc_option = 'a option
 type 'a mc_leftovers = (string * 'a) list
-type ('host, 'target) mc_lazy_t = ('host, 'target) Types.Result.t lazy_t
+type ('host, 'target) mc_lazy_t = ('host, 'target Types.Error.t) Types.Result.t lazy_t
 type 'target mc_fields = 'target Types.mc_fields

File lib/types.ml

   
   type 'target t = 'target desc * 'target
 
+  open Format
+
+  let rec format_list sep f ppf = function
+    | [] -> ()
+    | [x] -> f ppf x
+    | x::xs -> f ppf x; fprintf ppf sep; format_list sep f ppf xs
+
+  let format_desc f ppf = 
+    function
+      | Deconstruction_error exn -> 
+          fprintf ppf "Deconstruction error(%s)" (Printexc.to_string exn)
+      | Unknown_fields (tyname, fields) ->
+          fprintf ppf "@[<v2>Unknown fields of type %s:@ [ @[%a@] ]@]"
+            tyname
+            (format_list ";@ " (fun ppf (s, v) ->
+              fprintf ppf "@[<v2>%s=@ @[%a@]@]" s f v)) fields
+      | Required_fields_not_found (tyname, fields, _) ->
+          fprintf ppf "@[<v2>Required fields not found of type %s:@ [ @[%a@] ]@]"
+            tyname
+            (format_list ";@ " (fun ppf s -> fprintf ppf "%s" s)) fields
+      | Wrong_arity (exp, act, None) ->
+          fprintf ppf "Wrong arity of tuple %d (expected=%d)" act exp
+      | Wrong_arity (exp, act, Some (tyname, tag)) ->
+          fprintf ppf "Wrong arity of type %s of tag %s, %d (expected=%d)" tyname tag act exp
+      | Primitive_decoding_failure mes ->
+          fprintf ppf "Primitive decoding failure: %s" mes
+
+  let format f ppf (desc, _target : 'target t) = format_desc f ppf desc
+  
 end
 
 module Result = struct
 
   (** Result monad *)
-  type ('host, 'target) t =
-    [ `Ok of 'host 
-    | `Error of 'target Error.t
+  type ('a, 'error) t =
+    [ `Ok of 'a 
+    | `Error of 'error
     ]
 
   let bind t f = match t with
     | `Ok v -> f v
-    | `Error (err, v) -> `Error (err, v)
+    | `Error err -> `Error err
 
   let (>>=) = bind
 
   let fmap f t = match t with
     | `Ok v -> `Ok (f v)
-    | `Error (err, v) -> `Error (err, v)
+    | `Error err -> `Error err
 
   let map dec ts =
     let rec map st = function
       | t::ts -> 
           match dec t with
           | `Ok h -> map (h::st) ts
-          | `Error (err, t) -> `Error (err, t)
+          | `Error err -> `Error err
     in
     map [] ts
+
+  module Open = struct
+    let (>>=) = (>>=)
+  end
 end
 
 module Decoder = struct
-  type ('host, 'target) t = 'target -> ('host, 'target) Result.t
+  type ('host, 'target) t = 'target -> ('host, 'target Error.t) Result.t
   type ('host, 'target) t_exn = 'target -> 'host
 end
 
-type ('host, 'target) mc_lazy_t = ('host, 'target) Result.t lazy_t
+type ('host, 'target) mc_lazy_t = ('host, 'target Error.t) Result.t lazy_t
 
 type 'target mc_fields = (string * 'target) list
 (** Not-yet-decoded fields *)

File lib/types.mli

   
   type 'target t = 'target desc * 'target
 
+  val format : (Format.formatter -> 'target -> unit) -> Format.formatter -> 'target t -> unit
+  val format_desc : (Format.formatter -> 'target -> unit) -> Format.formatter -> 'target desc -> unit
 end
 
 module Result : sig
 
   (** Result monad *)
-  type ('host, 'target) t =
-    [ `Ok of 'host 
-    | `Error of 'target Error.t
+  type ('a, 'error) t =
+    [ `Ok of 'a 
+    | `Error of 'error
     ]
 
-  val bind : ('a, 'target) t -> ('a -> ('b, 'target) t) -> ('b, 'target) t
-  val (>>=) : ('a, 'target) t -> ('a -> ('b, 'target) t) -> ('b, 'target) t
-  val fmap : ('a -> 'b) -> ('a, 'target) t -> ('b, 'target) t
+  val bind : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
+  val (>>=) : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
+  val fmap : ('a -> 'b) -> ('a, 'error) t -> ('b, 'error) t
 
-  val map : ('a -> ('b, 'c) t) -> 'a list -> ('b list, 'c) t
+  val map : ('a -> ('b, 'error) t) -> 'a list -> ('b list, 'error) t
+
+  module Open : sig
+    val (>>=) : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
+  end
 end
 
 module Decoder : sig
-  type ('host, 'target) t = 'target -> ('host, 'target) Result.t
+  type ('host, 'target) t = 'target -> ('host, 'target Error.t) Result.t
   type ('host, 'target) t_exn = 'target -> 'host
 end
 
-type ('host, 'target) mc_lazy_t = ('host, 'target) Result.t lazy_t
+type ('host, 'target) mc_lazy_t = ('host, 'target Error.t) Result.t lazy_t
 
 type 'target mc_fields = (string * 'target) list
 (** Not-yet-decoded fields *)
-version = "0.10.0"
+version = "0.11.0"
 description = "ocaml_conv - type_conv, meta_conv based OCaml value printer"
-requires = "meta_conv"
-archive(byte) = "ocaml_conv.cmo"
-archive(native) = "ocaml_conv.cmx"
-exists_if = "ocaml_conv.cma"
+requires = "meta_conv,compiler-libs.common"
+archive(byte) = "ocaml_conv.cma"
+archive(native) = "ocaml_conv.cmxa"
 
 

File ocaml/META.in

+version = "@version@"
+description = "ocaml_conv - type_conv, meta_conv based OCaml value printer"
+requires = "meta_conv,compiler-libs.common"
+archive(byte) = "ocaml_conv.cma"
+archive(native) = "ocaml_conv.cmxa"
+
+

File ocaml/OMakefile

 OCAMLINCLUDES += ../lib
 
+OCAMLPACKS[] =
+    compiler-libs.common
+
 LIBFILES[] =
-   ocaml
-   ocaml_conv
+    ocaml
+    ocaml_conv
 
-LIB = ocaml_conv
+LIB[] = 
+    ocaml_conv
 
 MyOCamlLibrary($(LIB), $(LIBFILES))
 

File ocaml/ocaml.ml

   | List of t list
   | Array of t list
   | Variant of string * t list
+  | Poly_variant of string * t list (* Note that it is different from OCaml implementation *)
   | Record of (string * t) list
+  | Object of (string * t) list
   | Tuple of t list
   | Unit
 
 	(fun ppf -> fprintf ppf sep)
 	(format_list sep f) xs
 
-let rec format ppf = function
-  | Bool b -> fprintf ppf "%b" b
-  | Int31 i -> fprintf ppf "%d" i
-  | Int63 i -> fprintf ppf "%Ld" i
-  | Int32 i -> fprintf ppf "%ldl" i
-  | Int64 i -> fprintf ppf "%LdL" i
-  | Nativeint32 i -> fprintf ppf "%ldn" i
-  | Nativeint64 i -> fprintf ppf "%Ldn" i
-  | Float f -> fprintf ppf "%F" f
-  | Char c -> fprintf ppf "%C" c
-  | String s -> fprintf ppf "%S" s
-  | List ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
-  | Array ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
-  | Variant (tag, []) -> fprintf ppf "%s" tag
-  | Variant (tag, ts) -> fprintf ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
-  | Record fields -> fprintf ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (f, v) -> fprintf ppf "%s= %a" f format v)) fields
-  | Tuple ts -> fprintf ppf "(@[<2>%a@])" (format_list ",@ " format) ts
-  | Unit -> fprintf ppf "()"
+let format ?(no_poly=false) ppf v = 
+  let rec format ppf = function
+    | Bool b -> fprintf ppf "%b" b
+    | Int31 i -> fprintf ppf "%d" i
+    | Int63 i -> fprintf ppf "%Ld" i
+    | Int32 i -> fprintf ppf "%ldl" i
+    | Int64 i -> fprintf ppf "%LdL" i
+    | Nativeint32 i -> fprintf ppf "%ldn" i
+    | Nativeint64 i -> fprintf ppf "%Ldn" i
+    | Float f -> fprintf ppf "%F" f
+    | Char c -> fprintf ppf "%C" c
+    | String s -> fprintf ppf "%S" s
+    | List [] -> fprintf ppf "[]"
+    | List ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
+    | Array ts -> fprintf ppf "[ @[%a@] ]" (format_list ";@ " format) ts
+    | Variant (tag, []) -> fprintf ppf "%s" tag
+    | Variant (tag, [t]) -> fprintf ppf "@[<2>%s@ @[%a@]@]" tag format t
+    | Variant (tag, ts) -> fprintf ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
+    | Poly_variant (tag, [])  when no_poly -> fprintf ppf "%s" tag
+    | Poly_variant (tag, [t]) when no_poly -> fprintf ppf "@[<2>%s@ @[%a@]@]" tag format t
+    | Poly_variant (tag, ts)  when no_poly -> fprintf ppf "@[<2>%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
+    | Poly_variant (tag, []) -> fprintf ppf "`%s" tag
+    | Poly_variant (tag, [t]) -> fprintf ppf "@[<2>`%s@ @[%a@]@]" tag format t
+    | Poly_variant (tag, ts) -> fprintf ppf "@[<2>`%s@ (@[%a@])@]" tag (format_list ",@ " format) ts
+    | Record fields -> fprintf ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (f, v) -> fprintf ppf "%s= %a" f format v)) fields
+    | Object fields when no_poly -> fprintf ppf "@[<2>{ @[%a@] }@]" (format_list ";@ " (fun ppf (f, v) -> fprintf ppf "%s= %a" f format v)) fields
+    | Object fields -> fprintf ppf "@[@[<2>object@,@[%a@]@]@,end@]" (format_list "@ " (fun ppf (f, v) -> fprintf ppf "method %s= %a" f format v)) fields
+    | Tuple ts -> fprintf ppf "(@[%a@])" (format_list ",@ " format) ts
+    | Unit -> fprintf ppf "()"
+  in
+  format ppf v
 
-let format_with f ppf v = format ppf (f v)
+let format_with ?(no_poly=false) f ppf v = format ~no_poly ppf (f v)
+
+(** { 6 Parsing by compiler-libs } *)
+
+module Parser = struct
+  open Parsetree
+  open Longident
+  open Asttypes
+
+  type error = Location.t * [ `Invalid_construct | `Exn of exn ]
+  exception Error of error
+
+  let format_sprintf fmt = Format.(
+    let buf = Buffer.create 100 in
+    let ppf = formatter_of_buffer buf in
+    kfprintf (fun ppf -> pp_print_flush ppf (); Buffer.contents buf) ppf fmt
+  )
+
+  let show_error (loc, desc) = 
+    let desc = match desc with
+      | `Invalid_construct -> "invalid construct for simple ocaml value"
+      | `Exn (Failure s) -> "failure: " ^ s
+      | `Exn exn -> Printexc.to_string exn
+    in
+    if loc = Location.none then desc
+    else format_sprintf "%a: %s" Location.print loc desc
+
+  let exn loc ex = raise (Error (loc, `Exn ex))
+  let invalid loc = raise (Error (loc, `Invalid_construct))
+
+  (* We simply discard module paths *)
+  let strip loc = function
+    | Lident s -> s
+    | Ldot (_, s) -> s
+    | Lapply _ -> invalid loc
+
+  let rec structure sitems = List.map structure_item sitems
+    
+  and structure_item s = 
+    match s.pstr_desc with
+    | Pstr_eval e -> expression e
+    (* | Pstr_value of rec_flag * (pattern * expression) list *)
+    | _ -> invalid s.pstr_loc
+
+  and expression e =
+    match e.pexp_desc with
+    | Pexp_constant c -> constant c
+    | Pexp_tuple es -> tuple es
+    | Pexp_construct ({txt; _}, argopt, _) -> construct e.pexp_loc txt argopt
+    | Pexp_variant (l, expopt) -> variant l expopt
+    | Pexp_record (fields, None) -> record fields
+    | Pexp_array es -> array es
+    | Pexp_object class_str ->
+        (* Ignores class_str.pcstr_pat *)
+        object_ class_str.pcstr_fields
+    | _ -> invalid e.pexp_loc
+
+  and constant = function
+    | Const_char c -> Char c
+    | Const_string s -> String s
+    | Const_float s -> Float (float_of_string s)
+    | Const_int32 i32 -> Int32 i32
+    | Const_int64 i64 -> Int64 i64
+    (* Arch dependent int is coerced to int64 *)
+    | Const_int n -> Int63 (Int64.of_int n)
+    | Const_nativeint ni -> Nativeint64 (Int64.of_nativeint ni)
+
+  and tuple es = Tuple (List.map expression es)
+  and array es = Array (List.map expression es)
+
+  and variant l = function
+    | None -> Poly_variant (l, [])
+    | Some {pexp_desc= Pexp_tuple es; _} -> Poly_variant (l, List.map expression es)
+    | Some e -> Poly_variant (l, [expression e])
+
+  and record fields =
+    Record (List.map (fun ({txt = txt; loc}, e) ->
+      let e = expression e in
+      strip loc txt, e) fields)
+
+  and object_ fields =
+    Object (List.map (fun { pcf_desc; pcf_loc } -> match pcf_desc with
+    | Pcf_meth ({txt; _}, _, _, e) -> txt, expression e
+    | _ -> invalid pcf_loc) fields)
+
+  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])
+
+  let from_lexbuf lexbuf = 
+    try
+      Lexer.init (); (* not re-entrant *)
+      let str = Parser.implementation Lexer.token lexbuf in
+      structure str
+    with
+    | e -> exn Location.none e
+
+  let from f d = from_lexbuf (f d)
+  let from_channel  = from Lexing.from_channel
+  let from_string   =  from Lexing.from_string
+  let from_function = from Lexing.from_function
+end

File ocaml/ocaml.mli

   | List of t list
   | Array of t list
   | Variant of string * t list
+  | Poly_variant of string * t list
   | Record of (string * t) list
+  | Object of (string * t) list
   | Tuple of t list
   | Unit
 
 type ocaml = t
 
-val format : Format.formatter -> t -> unit
-val format_with : ('a -> t) -> Format.formatter -> 'a -> unit
+val format : ?no_poly: bool -> Format.formatter -> t -> unit
+val format_with : ?no_poly: bool -> ('a -> t) -> Format.formatter -> 'a -> unit
+(** [no_poly=true] prints polymorphic variants and objects as non-poly variants and records *)
+
+
+module Parser : sig
+  
+  type error = Location.t * [ `Invalid_construct | `Exn of exn ]
+  exception Error of error
+  val show_error : error -> string
+
+  (** They are not re-entrant, since OCaml's lexer is not. *)
+  val from_lexbuf   : Lexing.lexbuf -> t list
+  val from_channel  : in_channel -> t list
+  val from_string   : string -> t list
+  val from_function : (string -> int -> int) -> t list
+end
+

File ocaml/ocaml_conv.ml

 module Encode = struct
   let tuple ts = Tuple ts
   let variant tag ts = Variant (tag, ts)
+  let poly_variant tag ts = Poly_variant (tag, ts)
   let record fields = Record fields
+  let object_ fields = Object fields
 end
 
 let ocaml_of_unit () = Unit
     | Tuple ts -> ts
     | _ -> failwith "Tuple expected for tuple"
 
+  (* Variants and poly variants, and records and objects 
+     are compatible each other, resp.ly. *)
+
   let variant = function 
     | Variant (tag, ts) -> tag, ts
+    | Poly_variant (tag, ts) -> tag, ts
     | _ -> failwith "Variant expected for variant"
 
+  let poly_variant = function 
+    | Variant (tag, ts) -> tag, ts
+    | Poly_variant (tag, ts) -> tag, ts
+    | _ -> failwith "Poly_variant expected for poly_variant"
+
   let record = function
     | Record alist -> alist
+    | Object alist -> alist
     | _ -> failwith "Record expected for record"
+
+  let object_ = function 
+    | Object alist -> alist
+    | Object alist -> alist
+    | _ -> failwith "Object expected for object"
+
 end
 
 let unit_of_ocaml = function

File ocaml/ocaml_conv.mli

 open Ocaml
 
 module Encode : sig
-  val tuple : t list -> t
+  val tuple   : t list -> t
   val variant : string -> t list -> t
-  val record : (string * t) list -> t
+  val poly_variant : string -> t list -> t
+  val record  : (string * t) list -> t
+  val object_ : (string * t) list -> t
 end
 
 val ocaml_of_unit : unit -> t
 module Decode : sig
   val tuple   : ocaml -> ocaml list
   val variant : ocaml -> string * ocaml list
+  val poly_variant : ocaml -> string * ocaml list
   val record  : ocaml -> (string * ocaml) list
+  val object_ : ocaml -> (string * ocaml) list
 end
 
 val unit_of_ocaml : unit decoder

File ocaml/tests/OMakefile

 %.out.mli: %.mli ../../pa/pa_meta_conv.cma 
     camlp4o -I $(OCAMLFIND_DESTDIR)/type_conv pa_type_conv.cma ../../pa/pa_meta_conv.cma  -printer Camlp4OCamlPrinter $< > $@
 
+OCAMLC=ocamlfind ocamlc -package compiler-libs.common
+
 test.out: test.out.ml ../ocaml.cmo ../../lib/meta_conv.cmo ../../lib/meta_conv.cmi ../ocaml_conv.cma 
-    $(OCAMLC) -g -I .. -I ../../lib ../../lib/meta_conv.cmo ../ocaml_conv.cma test.out.ml -o $@
+    $(OCAMLC) -g -I .. -I ../../lib ../../lib/meta_conv.cmo ocamlcommon.cma ../ocaml_conv.cma test.out.ml -o $@
 
 %.out.auto.mli: %.out.ml ../ocaml.cmi ../ocaml_conv.cmi
     $(OCAMLC) -c -i -I .. -I ../../lib  test.out.ml > $@

File ocaml/tests/test.ml

 end
 
 module Test6 = struct
-  type t = { x : int; y : float; rest (:Leftovers:) : Ocaml.t mc_fields; } with conv (ocaml)
+  type t = { x : int; y : float; rest : Ocaml.t mc_leftovers; } with conv (ocaml)
   type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (ocaml)
 
   let format_t' = Ocaml.format_with ocaml_of_t'
     Format.eprintf "r' = %a@." format_t' r'
 end
 
+module Test7 = struct
+  type t = { x : int; y : float; rest : Ocaml.t mc_leftovers; } with conv (ocaml)
+  type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (ocaml)
+
+  let format_t = Ocaml.format_with ocaml_of_t
+
+  let () = 
+    let r' = { x' = 1; y' = 1.0; z' = () }  in
+    let format_sprintf fmt = Format.(
+      let buf = Buffer.create 100 in
+      let ppf = formatter_of_buffer buf in
+      kfprintf (fun ppf -> pp_print_flush ppf (); Buffer.contents buf) ppf fmt
+    ) in
+    let s = format_sprintf "%a" (Ocaml.format ~no_poly:false) (ocaml_of_t' r') in
+    prerr_endline s;
+    let o = match Ocaml.Parser.from_string s with [x] -> x | _ -> assert false in
+    Format.eprintf "parse done: %a@." (Ocaml.format ~no_poly:false) o;
+    try
+      let r = t_of_ocaml_exn o in
+      Format.eprintf "r = %a@." format_t r
+    with
+    | Ocaml_conv.Error e -> 
+        Format.eprintf "ERR: %a@." (Meta_conv.Types.Error.format Ocaml.format) e
+end
+

File pa/OMakefile

File contents unchanged.

File pa/pa_meta_conv.ml

 let annotations = Hashtbl.create 31
 
 EXTEND Gram
-  GLOBAL: constructor_declaration constructor_declarations label_declaration
-          type_declaration
+  GLOBAL: constructor_declaration constructor_declarations row_field label_declaration
+          type_declaration meth_decl
   ;
   
   constructor_declaration: 
             <:ctyp< $uid:s$ >>
       ] ];
 
+  row_field:
+      [ [ "`"; i = a_ident; "(:"; e = expr; ":)" -> 
+           Hashtbl.add annotations (_loc,i) e;
+           <:ctyp< `$i$ >>
+        | "`"; i = a_ident; "as"; n = a_STRING -> 
+           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           <:ctyp< `$i$ >>
+        | "`"; i = a_ident; "(:"; e = expr; ":)"; "of"; "&"; t = amp_ctyp -> 
+           Hashtbl.add annotations (_loc,i) e;
+           <:ctyp< `$i$ of & $t$ >>
+        | "`"; i = a_ident; "as"; n = a_STRING; "of"; "&"; t = amp_ctyp -> 
+           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           <:ctyp< `$i$ of & $t$ >>
+        | "`"; i = a_ident; "(:"; e = expr; ":)"; "of"; t = amp_ctyp -> 
+           Hashtbl.add annotations (_loc,i) e;
+           <:ctyp< `$i$ of $t$ >>
+        | "`"; i = a_ident; "as"; n = a_STRING; "of"; t = amp_ctyp -> 
+           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           <:ctyp< `$i$ of $t$ >>
+      ] ]
+    ;
+
   label_declaration:
     [ [ s = a_LIDENT; "(:"; e = expr; ":)"; ":"; t = poly_type ->  
             Hashtbl.add annotations (_loc,s) e;
           Ast.TyDcl(_loc, n, tpl, tk, cl)
     ] ];
 
+  meth_decl:
+      [ [ lab = a_LIDENT; "(:"; e = expr; ":)"; ":"; t = poly_type -> 
+          Hashtbl.add annotations (_loc, lab) e;
+          TyCol (_loc, 
+                 TyId(_loc, <:ident< $lid:lab$ >> ), 
+                 t )
+        | lab = a_LIDENT; "as"; n = a_STRING; ":"; t = poly_type -> 
+          Hashtbl.add annotations (_loc, lab) <:expr< $str:n$ >>;
+          TyCol (_loc, 
+                 TyId(_loc, <:ident< $lid:lab$ >> ), 
+                 t )
+      ] ]
+    ;
+
   (*  `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag *)
 
 (*  comma_idents:
 
 (* annotation parsing ******************************************************)
 
-let rec split_by_comma = function
-  | <:expr< $e1$, $e2$ >> -> split_by_comma e1 @ split_by_comma e2
-  | <:expr< >> -> []
-  | <:expr< $e$ >> -> [e]
-
 type type_name_annotation_semantics = {
   field_check : expr option;
 }
     default_type_name_annotation_semantics
     annots
 
-let interprete_variant_annotation loc id = 
-  let id_name = name_of_ident id  in
+let interprete_variant_annotation loc id_name = 
   match Hashtbl.find_all annotations (loc, id_name) with
   | [ <:expr< $str:x$ >> ] -> x
   | [] -> id_name
       optional : bool;
       leftovers : bool }
 
-let interprete_record_field_annotation loc id ctyp = 
+let interprete_record_field_annotation target_type_path loc id ctyp = 
   let name = name_of_ident id  in
   let optional = match ctyp with
     | <:ctyp< $_$ mc_option >>
     | _ -> false
   in
   let leftovers = match ctyp with
-    | <:ctyp< $_$ mc_leftovers >> -> true
+    | <:ctyp< $id:id$ mc_leftovers >> -> 
+        (* Leftover is only enabled for conv(a) where a = target_type_path *)
+        same_idents target_type_path id
     | _ -> false
   in
   let annots = 
   let st0 = { name; optional; leftovers } in
   List.fold_left (fun st -> function
     | <:expr< $str:x$ >> -> { st with name = x }
-    | <:expr< Leftovers >> -> { st with leftovers = true }
     | _ -> prerr_endline "Unknown (: .. :) meta_conv annotation"; assert false) st0 annots
 
 (* code generators ******************************************************)
   
   open A
 
+  (** for [X; Y; .. ], Z and BASE, build (X -> BASE) -> (Y -> BASE) -> ... -> Z -> BASE *)
+  let dispatch_type params z base = 
+    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$ -> $base$) -> $st$ >>) params <:ctyp< $z$ -> $base$ >>
+  
+  let func_type params name = 
+    create_for_all params 
+      (dispatch_type params 
+         (create_param_type params name)
+         <:ctyp< $id:target_type_path$ >>)
+
+  let dcl _loc name (params : ctyp list) exp =
+    <:binding<
+      $lid: A.conv_name ^ "_of_" ^ name$ : $func_type params name$ = 
+        $Gen.abstract _loc (List.map patt_of_tvar params) exp$
+    >>
+  
   let rec gen_ctyp : ctyp -> expr = function
     | TyId (loc, id) ->  (* int *)
         <:expr@loc< $id: change_id (fun s -> A.conv_name ^ "_of_" ^ s) id$ >>
           (create_expr_app 
            <:expr< $id:module_path$.Encode.tuple >>
              [create_list (List.map2 (fun id ctyp ->
-               let f = gen_ctyp ctyp in
-               <:expr< $f$ $expr_of_id id$ >>
+               <:expr< $gen_ctyp ctyp$ $expr_of_id id$ >>
              ) ids ctyps)])
+
+    | (TyVrnEq _ as ctyp) ->  (* polymorphic variants w/o > < sign *)
+        let loc, cases = deconstr_variant_type ctyp in
+        gen_variants loc cases
+
+    | (TyObj _ as ctyp) -> 
+        let loc, cases, flag = deconstr_object_type ctyp in
+        (* I dunno how to handle open fields *)
+        begin match flag with
+        | RvRowVar | RvAnt _ -> assert false
+        | RvNil -> () end;
+        gen_object loc cases
+        
     | _ -> assert false
     
-  let alias _name _tyd_loc _loc cty = 
-    let f = gen_ctyp cty in
-    <:expr< fun __value -> $f$ __value >>
-    
-  let sum _name _tyd_loc _loc ctyp = 
-    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
-    let case loc id ctyp =
-      let id_name = interprete_variant_annotation loc id in
+  and gen_variants _loc cases = 
+    let case (loc, idstr, ctyps) =
+      let id_name = interprete_variant_annotation loc idstr in
+      let ids = mk_idents "__x" (List.length ctyps) in
+      let patt = create_patt_app <:patt@loc< `$idstr$ >> (List.map patt_of_id ids) in
+      let exp = create_expr_app 
+        <:expr< $id:module_path$.Encode.poly_variant >>
+        [ <:expr< $str: id_name$ >>;
+          create_list (List.map2 (fun id ctyp ->
+            <:expr< $gen_ctyp ctyp$ $expr_of_id id$ >>
+          ) ids ctyps) ]
+      in
+      <:match_case< $ patt $ -> $ exp $ >>
+    in
+    <:expr< function $mcOr_of_list (List.map case cases)$ >>
 
-      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
+  and gen_object _loc field_types =
+    (* CR jfuruse: object types cannot have type ename annotation *)
+    (* let _annot = interprete_type_name_annotation tyd_loc name in *)
+    let fields, rest = List.fold_right (fun (loc, lab_id, ctyp) (fields, rest) ->
+      let f = gen_ctyp (strip_field_flags ctyp) in
+      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      match sem with
+      | { leftovers = true; _ } ->
+          fields, Some <:expr< __value#$name_of_ident lab_id$ >>
+      | { name = s; optional = true; _ } ->
+          <:expr< match __value#$name_of_ident lab_id$ with 
+                   | None -> None 
+                   | Some v -> Some ($str:s$, $f$ v) >>
+          :: fields,
+        rest
+      | { name = s; _ } ->
+          <:expr< Some ($str:s$, $f$ __value#$name_of_ident lab_id$) >> :: fields,
+        rest) field_types ([], None)
+    in
+    let exp = <:expr< Meta_conv.Internal.list_filter_map (fun x -> x) $create_list fields$ >> in
+    let exp = match rest with
+      | None -> exp
+      | Some e -> <:expr< $exp$ @ $e$ >>
+    in
+    <:expr< (fun __value -> $id:module_path$.Encode.object_ $exp$) >>
+
+  let sum tyd_loc name params _loc cases = 
+    let case (loc, id, ctyps) =
+      let id_name = interprete_variant_annotation loc (name_of_ident id) in
       let ids = mk_idents "__x" (List.length ctyps) in
       let patt = create_patt_app <:patt@loc< $id:id$ >> (List.map patt_of_id ids) in
       let exp = create_expr_app 
         <:expr< $id:module_path$.Encode.variant >>
         [ <:expr< $str: id_name$ >>;
-          (* CR jfuruse: dupe in gen_ctyp *)
           create_list (List.map2 (fun id ctyp ->
-            let f = gen_ctyp ctyp in
-            <:expr< $f$ $expr_of_id id$ >>
+            <:expr< $gen_ctyp ctyp$ $expr_of_id id$ >>
           ) ids ctyps) ]
       in
       <:match_case< $ patt $ -> $ exp $ >>
     in
-    let cases = 
-      List.map (function
-        | <:ctyp@loc< $id:id$ of $ctyp$ >> -> case loc id ctyp
-        | <:ctyp@loc< $id:id$ >> -> case loc id (TyNil _loc)
-        | _ -> assert false
-      ) constrs 
+    [dcl tyd_loc name params <:expr< function $mcOr_of_list (List.map case cases)$ >>]
+  
+  let alias tyd_loc name params _loc cty = 
+    let f = gen_ctyp cty in
+    [ dcl tyd_loc name params <:expr< fun __value -> $f$ __value >> ]
+    
+  let record tyd_loc name params _loc field_types = 
+    let _annot = interprete_type_name_annotation tyd_loc name in
+    let fields, rest = List.fold_right (fun (loc, lab_id, ctyp) (fields, rest) ->
+      let f = gen_ctyp (strip_field_flags ctyp) in
+      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      match sem with
+      | { leftovers = true; _ } ->
+          fields, Some <:expr< __value.$id:lab_id$ >>
+      | { name = s; optional = true; _ } ->
+          <:expr< match __value.$id:lab_id$ with 
+                   | None -> None 
+                   | Some v -> Some ($str:s$, $f$ v) >>    
+          :: fields,
+          rest
+      | { name = s; _ } ->
+          <:expr< Some ($str:s$, $f$ __value.$id:lab_id$) >>
+          :: fields,
+        rest) field_types ([], None)
     in
-    <:expr< fun __value -> match __value with $mcOr_of_list cases$ >>
-  
-  let record name tyd_loc _loc ctyp = 
-    let _annot = interprete_type_name_annotation tyd_loc name in
-    let ctyps = list_of_ctyp ctyp [] in (* decomp TySems *)
-    let fields, rest = List.fold_right (fun ctyp (fields, rest) ->
-      match ctyp with
-      | TyCol (loc, TyId(_, lab_id), ctyp) -> 
-          let f = gen_ctyp (strip_field_flags ctyp) in
-          let sem = interprete_record_field_annotation loc lab_id ctyp in
-          begin match sem with
-          | { leftovers = true; _ } ->
-              fields, Some <:expr< __value.$id:lab_id$ >>
-          | { name = s; optional = true; _ } ->
-              <:expr< match __value.$id:lab_id$ with 
-                      | None -> None 
-                      | Some v -> Some ($str:s$, $f$ v) >> :: fields,
-              rest
-          | { name = s; _ } ->
-              <:expr< Some ($str:s$, $f$ __value.$id:lab_id$) >> :: fields,
-              rest
-          end
-      | _ -> assert false) ctyps ([], None)
-    in
-    (* CR jfuruse: option map should be in the libarary *)
-    let exp = <:expr<
-      List.fold_right (fun x st -> match x with None -> st | Some v -> v::st) $create_list fields$ []
-      >>
-    in
+    let exp = <:expr< Meta_conv.Internal.list_filter_map (fun x -> x) $create_list fields$ >> in
     let exp = match rest with
       | None -> exp 
       | Some e -> <:expr< $exp$ @ $e$ >>
     in
-    <:expr< fun __value -> $id:module_path$.Encode.record $exp$ >>
+    [ dcl tyd_loc name params <:expr< (fun __value -> $id:module_path$.Encode.record $exp$) >>;
+    ]
     
-  (** for [X; Y; .. ], Z and BASE, build (X -> BASE) -> (Y -> BASE) -> ... -> Z -> BASE *)
-  let dispatch_type params z base = 
-    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$ -> $base$) -> $st$ >>) params <:ctyp< $z$ -> $base$ >>
-  
-  let func_type params name = 
-    create_for_all params (dispatch_type params 
-                             (create_param_type params name)
-                             <:ctyp< $id:target_type_path$ >>)
+  let variants tyd_loc name params _loc cases = 
+    [ dcl tyd_loc name params (gen_variants tyd_loc cases) ]
   
   (******************* kind of template *)
   
-  let def name loc cty =
-    let variants _ = assert false in
-    let mani     _ = assert false in
-    let nil      _ = assert false in
-    let alias  = alias name loc in
-    let sum    = sum name loc in
-    let record = record name loc in
-    Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil cty
-  
-  
-  let dcl _loc name (params : ctyp list) d =
-    <:binding<
-      $lid: A.conv_name ^ "_of_" ^ name$ : $func_type params name$ = 
-        $Gen.abstract _loc (List.map patt_of_tvar params) (def name _loc d)$
-    >>
+  let def defloc name params cty =
+    match deconstr_tydef cty with
+    | `Variant (loc, cases)  -> variants defloc name params loc cases
+    | `Sum     (loc, cases)  -> sum      defloc name params loc cases
+    | `Record  (loc, fields) -> record   defloc name params loc fields
+    | `Alias   (loc, ctyp)   -> alias    defloc name params loc ctyp
+    | _ -> assert false
   
   (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *)
   let str = fun rec_ tds ->
-      let _loc = Ast.loc_of_ctyp tds in
-      let decls = list_of_ctyp tds [] in
-      let recursive = type_definitions_are_recursive rec_ tds in
-      let binds = List.map (function
-        | TyDcl (loc, name, params, def, _constraints) -> 
-            dcl loc name params def
-        | _ -> assert false) decls
-      in
-      create_top_let recursive binds
+    let _loc = Ast.loc_of_ctyp tds in
+    let decls = list_of_ctyp tds [] in
+    let recursive = type_definitions_are_recursive rec_ tds in
+    let binds = List.flatten (List.map (function
+      | TyDcl (loc, name, params, definition, _constraints) -> 
+          def loc name params definition
+      | _ -> assert false) decls)
+    in
+    create_top_let recursive binds
 
-  let dcl_sg _loc name (params : ctyp list) _d =
+  let dcl_sg _loc name (params : ctyp list) _cty = 
     <:sig_item<
       val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
     >>
   
   let sg = fun _rec_ tds ->
-      let _loc = Ast.loc_of_ctyp tds in
-      let decls = list_of_ctyp tds [] in
-      let items = List.map (function
-        | TyDcl (loc, name, params, def, _constraints) -> 
-            dcl_sg loc name params def
-        | _ -> assert false) decls
-      in
-      concat_sig_items items
+    let _loc = Ast.loc_of_ctyp tds in
+    let decls = list_of_ctyp tds [] in
+    let items = List.map (function
+      | TyDcl (loc, name, params, def, _constraints) -> 
+          dcl_sg loc name params def
+      | _ -> assert false) decls
+    in
+    concat_sig_items items
 
 end
   
   
   open A
 
+  (** for [X; Y; .. ], Z and BASE, build (X,BASE) Decoder.t -> (Y,BASE) Decoder.t -> ...... -> (Z,BASE) Decoder.T *)
+  let gen_dispatch_type t params base z = 
+    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$, $base$) Meta_conv.Types.Decoder.t -> $st$ >>) 
+      params <:ctyp< ($z$,$base$) Meta_conv.Types.Decoder.$id:t$ >>
+  
+  let dispatch_type     = gen_dispatch_type <:ident<t>>
+  let dispatch_type_exn = gen_dispatch_type <:ident<t_exn>>
+
+  let gen_func_type disp params name = 
+    create_for_all params 
+      (disp params 
+         <:ctyp< $id:target_type_path$ >> 
+         (create_param_type params name))
+
+  let func_type     = gen_func_type dispatch_type
+  let func_type_exn = gen_func_type dispatch_type_exn
+  
   let binds ids exps final = List.fold_right2 (fun id exp st ->
     <:expr< Meta_conv.Types.Result.bind $exp$ (fun $id:id$ -> $st$) >>) 
     ids exps <:expr< `Ok $final$ >>
 
-  let rec gen_ctyp : ctyp -> expr = function
+  (* Like type t = [ `Foo ], sometimes structural polymorphic types have
+     names. [type_name] is for it.
+
+     For type t = int * [ `Foo ], [ `Foo ] has no good name, so we use
+     its position.
+  *)
+  let rec gen_ctyp : ?type_name: string -> ctyp -> expr = fun ?type_name -> function
     | TyId (loc, id) ->  (* int *)
         <:expr@loc< $id: change_id (fun s -> s ^ "_of_" ^ A.conv_name) id$ >>
 
           | $pat$ -> $binds$
           | l -> Meta_conv.Internal.tuple_arity_error $int:string_of_int len$ (List.length l) __value
         >>
+
+    | (TyVrnEq _ as ctyp) ->  (* polymorphic variants w/o > < sign *)
+        let loc, cases = deconstr_variant_type ctyp in
+        gen_variants ?type_name loc cases
+
+    | (TyObj _ as ctyp) ->
+        let loc, cases, flag = deconstr_object_type ctyp in
+        (* I dunno how to handle open fields *)
+        begin match flag with
+        | RvRowVar | RvAnt _ -> assert false
+        | RvNil -> () end;
+        gen_object ?type_name loc cases
+        
     | _ -> assert false
-  
-  let alias _name _tyd_loc _loc cty = 
-    let f = gen_ctyp cty in
-    <:expr< fun __value -> $f$ __value >>
+    
+  and gen_variants ?type_name _loc cases = 
+    let name = match type_name with
+      | Some type_name -> type_name
+      | None -> Printf.sprintf "poly-variant at %s" (Loc.to_string _loc) 
+    in
+    let case (loc, idstr, ctyps) =
+      let id_name = interprete_variant_annotation loc idstr in
+
+      let len = List.length ctyps in
+      let ids = mk_idents "__x" len in
+
+      let exps = List.map2 (fun id ctyp -> 
+        <:expr< $gen_ctyp ctyp$ $id:id$ >> ) ids ctyps 
+      in
+      let final = create_expr_app <:expr< `$idstr$ >> (List.map expr_of_id ids) in
+      (* id_name, [ ids ] *)
+      <:match_case< 
+        ($str:id_name$, l) -> begin match l with 
+          | $create_patt_list (List.map patt_of_id ids)$ ->
+              $ binds ids exps final $
+          | _ -> 
+              Meta_conv.Internal.variant_arity_error 
+                __name $str:id_name$ $int:string_of_int len$ (List.length l)
+                __value
+          end
+        >> 
+    in
+    let default = <:match_case<
+      name, l -> 
+        Meta_conv.Internal.variant_unknown_tag_error 
+          __name name __value
+      >>
+    in
+    let cases = List.map case cases @ [ default ] in
+    <:expr< fun __value -> 
+      let __name = $str:name$ in
+      match $id:module_path$.Decode.poly_variant __value with 
+        $mcOr_of_list cases$ 
+    >>
+
+  and gen_object ?type_name _loc field_types = 
+    let name = match type_name with
+      | Some type_name -> type_name
+      | None -> Printf.sprintf "object at %s" (Loc.to_string _loc) 
+    in
+    (* CR jfuruse: objects cannot have type name annotation *)
+    (* let annot = interprete_type_name_annotation tyd_loc name in *)
+    let annot = default_type_name_annotation_semantics in
+    let labels, fields, rest = List.fold_right (fun (loc, lab_id, ctyp) (labs, st, rest) ->
+      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      let ctyp = strip_field_flags ctyp in
+      match sem with
+      | { leftovers = true; _ }-> 
+          labs, (lab_id, <:expr< `Ok unknown_fields >>) :: st, Some lab_id
+      | { name=key; optional = true; _ } -> 
+          let conv = gen_ctyp ctyp in
+          key :: labs,
+          (lab_id, 
+           <:expr< Meta_conv.Internal.field_assoc_optional __name __value $str:key$ fields $conv$ >>)
+          :: st,
+          rest
+      | { name=key; _ } -> 
+          let conv = gen_ctyp ctyp in
+          key :: labs,
+          (lab_id, 
+           <:expr< Meta_conv.Internal.field_assoc __name __value $str:key$ fields $conv$ >>)
+          :: st,
+          rest) field_types ([], [], None)
+    in
+    let unknown_fields_check = match annot.field_check, rest with
+      | None, Some _ -> failwith "Ignore_unknown_fields and Leftovers cannot be specified at the same time"
+      | None, _ | Some _, Some _ -> <:expr< Meta_conv.Internal.record_ignore_unknown_fields >>
+      | Some e, _ -> e
+    in
+
+    let labels = create_list (List.map (fun x -> <:expr< $str:x$ >>) labels) in
+
+    let the_builder =
+      let final = create_expr_app <:expr<__f>> (List.map (fun (id, _) -> expr_of_id id) fields) in
+      binds (List.map fst fields) (List.map snd fields) final
+    in
+    
+    let the_object = 
+      Gen.abstract _loc (List.map (fun (id, _) -> <:patt<$id:id$>>) fields)
+        (create_object (List.map (fun (id, _) -> name_of_ident id, expr_of_id id) fields))
+    in
+    
+    <:expr< fun __value -> 
+        let __name = $str:name$ in
+        let valid_labels = $labels$ in
+        let fields = $id:module_path$.Decode.object_ __value in 
+        let unknown_fields = Meta_conv.Internal.filter_record_fields valid_labels fields in
+        let __f = $the_object$ in
+        $unknown_fields_check$ __name __value unknown_fields (fun () -> 
+          $the_builder$) 
+        >>
+
+  let dcl _loc name (params : ctyp list) body =
+    [ `MayRec <:binding<
+          $lid: name ^ "_of_" ^ A.conv_name$ : $func_type params name$ = 
+          $Gen.abstract _loc (List.map patt_of_tvar params) body$
+          >>; 
+      `NoRec <:binding<
+          $lid: name ^ "_of_" ^ A.conv_name ^ "_exn"$ : $func_type_exn params name$ = 
+          $Gen.abstract _loc (List.map patt_of_tvar params) <:expr<
+            fun v -> 
+              match $ Gen.apply _loc <:expr< $lid: name ^ "_of_" ^ A.conv_name$ >> (List.map expr_of_tvar params)$ v with
+              | `Ok v -> v
+              | `Error (e, v) -> raise ($id:module_path$.Error (e, v))
+                  >> $
+        >> ]
+
+  let alias tyd_loc name params _loc cty = 
+    let f = gen_ctyp ~type_name: name cty in
+    dcl tyd_loc name params <:expr< fun __value -> $f$ __value >>
   ;;
 
-  let sum name _tyd_loc _loc ctyp = 
-    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
-    let case loc id ctyp =
-      let id_name = interprete_variant_annotation loc id in
+  let sum tyd_loc name params _loc cases = 
+    let case (loc, id, ctyps) =
+      let id_name = interprete_variant_annotation loc (name_of_ident id) in
 
-      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
       let len = List.length ctyps in
       let ids = mk_idents "__x" len in
 
               $ binds ids exps final $
           | _ -> 
               Meta_conv.Internal.variant_arity_error 
-                $str:name$ $str:id_name$ $int:string_of_int len$ (List.length l)
+                __name $str:id_name$ $int:string_of_int len$ (List.length l)
                 __value
           end
         >> 
     let default = <:match_case<
       name, l -> 
         Meta_conv.Internal.variant_unknown_tag_error 
-          $str:name$ name __value
+          __name name __value
       >>
     in
-    let cases = 
-      List.map (function
-        | <:ctyp@loc< $id:id$ of $ctyp$ >> -> case loc id ctyp
-        | <:ctyp@loc< $id:id$ >> -> case loc id (TyNil _loc)
-        | _ -> assert false
-      ) constrs @ [ default ]
-    in
-    <:expr< fun __value -> 
-      match $id:module_path$.Decode.variant __value with 
-        $mcOr_of_list cases$ 
-    >>
-  
-  let record ty_name tyd_loc _loc ctyp = 
-    let annot = interprete_type_name_annotation tyd_loc ty_name in
-    let ctyps = list_of_ctyp ctyp [] in (* decomp TySems *)
-    let labels, fields, rest = List.fold_right (fun ctyp (labs, st, rest) -> match ctyp with
-      | TyCol (loc, TyId(_, lab_id), ctyp) -> 
-          let sem = interprete_record_field_annotation loc lab_id ctyp in
-          let ctyp = strip_field_flags ctyp in
-          begin match sem with
-          | { leftovers = true; _ }-> 
-              labs, (lab_id, <:expr< `Ok unknown_fields >>) :: st, Some lab_id
-          | { name; optional = true; _ } -> 
-              let conv = gen_ctyp ctyp in
-              name :: labs,
-              (lab_id, 
-               <:expr< Meta_conv.Internal.field_assoc_optional $str:ty_name$ __value $str:name$ fields $conv$ >>)
-              :: st,
-              rest
-          | { name; _ } -> 
-              let conv = gen_ctyp ctyp in
-              name :: labs,
-              (lab_id, 
-               <:expr< Meta_conv.Internal.field_assoc $str:ty_name$ __value $str:name$ fields $conv$ >>)
-              :: st,
-              rest
-          end
-      | _ -> assert false) ctyps ([], [], None)
+    let cases = List.map case cases @ [ default ] in
+    dcl tyd_loc name params
+      <:expr< fun __value -> 
+        let __name = $str:name$ in
+        match $id:module_path$.Decode.variant __value with 
+          $mcOr_of_list cases$ 
+      >>
+      
+  let record tyd_loc name params _loc field_types = 
+    let annot = interprete_type_name_annotation tyd_loc name in
+    let labels, fields, rest = List.fold_right (fun (loc, lab_id, ctyp) (labs, st, rest) ->
+      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      let ctyp = strip_field_flags ctyp in
+      match sem with
+      | { leftovers = true; _ }-> 
+          labs, (lab_id, <:expr< `Ok unknown_fields >>) :: st, Some lab_id
+      | { name=key; optional = true; _ } -> 
+          let conv = gen_ctyp ctyp in
+          key :: labs,
+          (lab_id, 
+           <:expr< Meta_conv.Internal.field_assoc_optional __name __value $str:key$ fields $conv$ >>)
+          :: st,
+          rest
+      | { name=key; _ } -> 
+          let conv = gen_ctyp ctyp in
+          key :: labs,
+          (lab_id, 
+           <:expr< Meta_conv.Internal.field_assoc __name __value $str:key$ fields $conv$ >>)
+          :: st,
+          rest) field_types ([], [], None)
     in
     let unknown_fields_check = match annot.field_check, rest with
       | None, Some _ -> failwith "Ignore_unknown_fields and Leftovers cannot be specified at the same time"
       | None, _ | Some _, Some _ -> <:expr< Meta_conv.Internal.record_ignore_unknown_fields >>
       | Some e, _ -> e
     in
+
+    let labels = create_list (List.map (fun x -> <:expr< $str:x$ >>) labels) in
+
+(*
     let the_record = 
+      Gen.abstract _loc (List.map (fun (id, _) -> <:patt<$id:id$>>) fields)
+        (create_record (List.map (fun (id, _) -> id, expr_of_id id) fields))
+    in
+    
+    let the_builder =
+      let final = create_expr_app the_record (List.map (fun (id, _) -> expr_of_id id) fields) in
+      binds (List.map fst fields) (List.map snd fields) final
+    in
+*)
+    let the_builder = 
       let final = create_record (List.map (fun (id, _) -> id, expr_of_id id) fields) in
       binds (List.map fst fields) (List.map snd fields) final
     in
-    
-    let labels = create_list (List.map (fun x -> <:expr< $str:x$ >>) labels) in
-    <:expr< fun __value -> 
+
+    dcl tyd_loc name params <:expr< fun __value -> 
+      let __name = $str:name$ in
       let valid_labels = $labels$ in
       let fields = $id:module_path$.Decode.record __value in 
       let unknown_fields = Meta_conv.Internal.filter_record_fields valid_labels fields in
-      $unknown_fields_check$ $str:ty_name$ __value unknown_fields (fun () -> 
-        $the_record$) 
-    >>
-    
-  (** for [X; Y; .. ], Z and BASE, build (X,BASE) Decoder.t -> (Y,BASE) Decoder.t -> ...... -> (Z,BASE) Decoder.t *)
-  let dispatch_type params base z = 
-    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$, $base$) Meta_conv.Types.Decoder.t -> $st$ >>) 
-      params <:ctyp< ($z$,$base$) Meta_conv.Types.Decoder.t >>
-  
-  let dispatch_type_exn params base z = 
-    List.fold_right (fun ctyp st -> <:ctyp< ($ctyp$, $base$) Meta_conv.Types.Decoder.t -> $st$ >>) 
-      params <:ctyp< ($z$,$base$) Meta_conv.Types.Decoder.t_exn >>
-  
-  let func_type params name = 
-    create_for_all params (dispatch_type params 
-       <:ctyp< $id:target_type_path$ >>
-       (create_param_type params name))
-  
-  let func_type_exn params name = 
-    create_for_all params (dispatch_type_exn params 
-       <:ctyp< $id:target_type_path$ >>
-       (create_param_type params name))
-  
+      $unknown_fields_check$ __name __value unknown_fields (fun () -> 
+        $the_builder$) 
+      >>
+
+  let variants tyd_loc name params _loc cases = 
+    dcl tyd_loc name params (gen_variants ~type_name:name _loc cases)
+
   (******************* kind of template *)
   
-  let def name loc cty =
-    let variants _ = assert false in
-    let mani     _ = assert false in
-    let nil      _ = assert false in
-    let alias  = alias name loc in
-    let sum    = sum name loc in
-    let record = record name loc in
-    Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil cty
+  let def defloc name params cty =
+    match deconstr_tydef cty with
+    | `Variant (loc, cases)  -> variants defloc name params loc cases
+    | `Sum     (loc, cases)  -> sum      defloc name params loc cases
+    | `Record  (loc, fields) -> record   defloc name params loc fields
+    | `Alias   (loc, ctyp)   -> alias    defloc name params loc ctyp
+    | _ -> assert false
   
-  
-  let dcl _loc name (params : ctyp list) d =
-    <:binding<
-      $lid: name ^ "_of_" ^ A.conv_name$ : $func_type params name$ = 
-        $Gen.abstract _loc (List.map patt_of_tvar params) (def name _loc d)$
-    >>, 
-    <:binding<
-      $lid: name ^ "_of_" ^ A.conv_name ^ "_exn"$ : $func_type_exn params name$ = 
-        $Gen.abstract _loc (List.map patt_of_tvar params) <:expr<
-          fun v -> 
-            match $ Gen.apply _loc <:expr< $lid: name ^ "_of_" ^ A.conv_name$ >> (List.map expr_of_tvar params)$ v with
-            | `Ok v -> v
-            | `Error (e, v) -> raise ($id:module_path$.Error (e, v))
-        >> $
-    >>
-  
-  (* Add "of_sexp" and "sexp_of" as "sexp" to the set of generators *)
-  let str = fun rec_ tds ->
-      let _loc = Ast.loc_of_ctyp tds in
-      let decls = list_of_ctyp tds [] in (* CR jfuruse: mutual *)
-      let recursive = type_definitions_are_recursive rec_ tds in
-      let binds = List.map (function
-        | TyDcl (loc, name, params, def, _constraints) -> 
-            dcl loc name params def
-        | _ -> assert false) decls
-      in
-      [ create_top_let recursive (List.map fst binds);
-        create_top_let recursive (List.map snd binds) ]
+  (* Add "of_xxx" and "xxx_of" as "xxx" to the set of generators *)
+  let str rec_ tds =
+    let _loc = Ast.loc_of_ctyp tds in
+    let decls = list_of_ctyp tds [] in
+    let recursive = type_definitions_are_recursive rec_ tds in
+    let binds = List.flatten (List.map (function
+      | TyDcl (loc, name, params, definition, _constraints) -> def loc name params definition
+      | _ -> assert false) decls)
+    in
+    create_top_let recursive (List.fold_right (fun bind st -> 
+        match bind with
+        | `MayRec bind -> bind :: st
+        | `NoRec _ -> st) binds [])
+    :: List.map (fun x -> create_top_let recursive [x]) (List.fold_right (fun bind st -> 
+        match bind with
+        | `NoRec bind -> bind :: st
+        | `MayRec _ -> st) binds [])
 
   let dcl_sg _loc name (params : ctyp list) _d =
     <:sig_item<
       val $lid: name ^ "_of_" ^ A.conv_name ^ "_exn"$ : $func_type_exn params name$
     >>
   
-  let sg = fun _rec_ tds ->
+  let sg _rec_ tds =
       let _loc = Ast.loc_of_ctyp tds in
       let decls = list_of_ctyp tds [] in
       let items = List.map (function

File pa/tctools.ml

 
 let _loc = Loc.ghost
 
+(** { 6 Tools } *)
+
 (** [ from_one_to n = [1; 2; ..; n] ] *)
 let from_one_to n = let rec loop i = if i > n then [] else i :: loop (i+1) in loop 1
 
+
+
+
+(** { 6 Idents and Paths } *)
+
 (** [mk_idents name n] creates idents from name1 to namen *) 
 let mk_idents : string -> int -> ident list = fun pref n ->
   List.map (fun i -> IdLid (_loc, pref ^ string_of_int i)) (from_one_to n)
 
-(** [patt_of_tvar tv] creates a pattern variable for a type variable [tv] *)
-let patt_of_tvar : ctyp -> patt = function
-  | <:ctyp<'$tv$>> -> <:patt< $lid:"__tv_" ^ tv$ >>
-  | _ -> assert false
-
-(** [expr_of_tvar tv] creates an expression variable for a type variable [tv] *)
-let expr_of_tvar : ctyp -> expr = function
-  | <:ctyp<'$tv$>> -> <:expr< $lid:"__tv_" ^ tv$ >>
-  | _ -> assert false
-
-(** [create_patt_app const args] creates a pattern of variant constructor like 
-    const (arg1,..,argn) *)
-let create_patt_app : patt -> patt list -> patt = fun f patts ->
-  List.fold_left (fun st p -> PaApp (_loc, st, p)) f patts
-
-(** [create_expr_app const args] creates an expr of variant constructor like 
-    const (arg1,..,argn) 
-  This is a variant of Gen.create_expr_app *)
-let create_expr_app : expr -> expr list -> expr = fun f exprs ->
-  List.fold_left (fun st p -> ExApp (_loc, st, p)) f exprs
-
-let rec concat_class_str_items : class_str_item list -> class_str_item = function
-  | [] -> CrNil _loc
-  | [x] -> x
-  | x::xs -> CrSem (_loc, x, concat_class_str_items xs)
-
-let rec concat_let_bindings : binding list -> binding = function
-  | [] -> BiNil _loc
-  | [x] -> x
-  | x::xs -> BiAnd (_loc, x, concat_let_bindings xs)
-
-let rec concat_str_items : str_item list -> str_item = function
-  | [] -> StNil _loc
-  | [x] -> x
-  | x::xs -> StSem (_loc, x, concat_str_items xs)
-
-let rec concat_sig_items : sig_item list -> sig_item = function
-  | [] -> SgNil _loc
-  | [x] -> x
-  | x::xs -> SgSem (_loc, x, concat_sig_items xs)
-
-(** [expr_of_id id] and [patt_of_id id] create an expr or patt of [id] correspondingly *)
-let expr_of_id : ident -> expr = fun id -> <:expr< $id:id$ >>
-let patt_of_id : ident -> patt = fun id -> <:patt< $id:id$ >>
-
-(** (p1, p2, .., pn) name *)
-let create_param_type : ctyp list -> string -> ctyp = fun params name ->
-  List.fold_left (fun st x -> TyApp (_loc, st, x)) <:ctyp< $lid: name$ >> params 
-
-(** p1 ... pn . ty *)
-let create_for_all : ctyp list -> ctyp -> ctyp = fun params ty -> match params with
-  | [] -> ty
-  | x::xs -> TyPol (_loc, List.fold_right (fun x st -> TyApp (_loc, st, x)) xs x, ty)
-
 (** A.x => A.y where y = f x *)
 let rec change_id f = function
   | IdAcc (loc, a, b) -> IdAcc (loc, a, change_id f b)
   | IdUid (_loc, s) -> String.uncapitalize s
   | _id -> assert false
 
+(** [expr_of_id id] and [patt_of_id id] create an expr or patt of [id] correspondingly *)
+let expr_of_id : ident -> expr = fun id -> <:expr< $id:id$ >>
+let patt_of_id : ident -> patt = fun id -> <:patt< $id:id$ >>
+
+(* Note: a.B.c.D is accepted *)    
+let convert_path ss =
+  let create = function
+    | "" -> assert false
+    | x -> match x.[0] with
+      | 'a'..'z' -> <:ident< $lid:x$ >> 
+      | 'A'..'Z' -> <:ident< $uid:x$ >>
+      | _ -> assert false
+  in
+  let rec concat = function
+    | [x] -> x
+    | x::xs -> <:ident< $x$ . $concat xs$ >>
+    | [] -> assert false
+  in
+  concat (List.map create ss)
+
+let name_of_ident = function
+  | IdUid (_, name) | IdLid (_, name) -> name
+  | _ -> assert false
+
+let strip_locs_of_ident id =
+  let rec f = function
+    | IdAcc (_, id1, id2) -> IdAcc (_loc, f id1, f id2)
+    | IdApp (_, id1, id2) -> IdApp (_loc, f id1, f id2)
+    | IdLid (_, s) -> IdLid (_loc, s)
+    | IdUid (_, s) -> IdUid (_loc, s)
+    | IdAnt _ -> assert false
+  in
+  f id
+
+let same_idents id1 id2 = strip_locs_of_ident id1 = strip_locs_of_ident id2
+
+(** { 6 Tvars } *)
+
+(** [patt_of_tvar tv] creates a pattern variable for a type variable [tv] *)
+let patt_of_tvar : ctyp -> patt = function
+  | <:ctyp<'$tv$>> -> <:patt< $lid:"__tv_" ^ tv$ >>
+  | _ -> assert false
+
+(** [expr_of_tvar tv] creates an expression variable for a type variable [tv] *)
+let expr_of_tvar : ctyp -> expr = function
+  | <:ctyp<'$tv$>> -> <:expr< $lid:"__tv_" ^ tv$ >>
+  | _ -> assert false
+
+
+(** { 6 Creators } *)
+
+(** [create_patt_app const args] creates a pattern of variant constructor like 
+    const (arg1,..,argn) *)
+let create_patt_app : patt -> patt list -> patt = fun f patts ->
+  List.fold_left (fun st p -> PaApp (_loc, st, p)) f patts
+
+(** [create_expr_app const args] creates an expr of variant constructor like 
+    const (arg1,..,argn) 
+  This is a variant of Gen.create_expr_app *)
+let create_expr_app : expr -> expr list -> expr = fun f exprs ->
+  List.fold_left (fun st p -> ExApp (_loc, st, p)) f exprs
+
+
+let create_top_let : bool -> binding list -> str_item = fun rec_ binds ->
+  let binds = 
+    let rec create_binds = function
+      | [] -> BiNil _loc
+      | x::xs -> BiAnd (_loc, x, create_binds xs)
+    in
+    create_binds binds 
+  in
+  if rec_ then <:str_item< let rec $binds$ >>
+  else <:str_item< let $binds$ >>
+
+
+(** { 6 Concatenations } *)
+
+let rec gen_concat_items : 'a -> ('a -> 'a -> 'a) -> 'a list -> 'a = 
+  fun nil cons xs ->
+    match xs with
+    | [] -> nil
+    | [x] -> x
+    | x::xs -> cons x (gen_concat_items nil cons xs)
+
+let concat_class_str_items = 
+  gen_concat_items (CrNil _loc) (fun x y -> CrSem (_loc, x, y))
+
+let concat_let_bindings =
+  gen_concat_items (BiNil _loc) (fun x y -> BiAnd (_loc, x, y))
+
+let concat_str_items =
+  gen_concat_items (StNil _loc) (fun x y -> StSem (_loc, x, y))
+
+let concat_sig_items =
+  gen_concat_items (SgNil _loc) (fun x y -> SgSem (_loc, x, y))
+
+
+
+(** { 6 Strippers } *)
+
+(** [strip_flags cty] removes mutable and private flags *)
+let rec strip_field_flags = function
+  | TyMut (_, cty) | TyPrv (_, cty) -> strip_field_flags cty
+  | cty -> cty
+
+(** forget the ident locations *)
+let rec strip_ident_loc : ident -> ident = function
+  | IdAcc(_, id1, id2) -> IdAcc(_loc, strip_ident_loc id1, strip_ident_loc id2)
+  | IdApp(_, id1, id2) -> IdApp(_loc, strip_ident_loc id1, strip_ident_loc id2)
+  | IdLid(_, n) -> IdLid(_loc, n)
+  | IdUid(_, n) -> IdUid(_loc, n)
+  | IdAnt(_, n) -> IdAnt(_loc, n)
+
+(** { 6 Deconstruction } *)
+
+let rec split_by_comma = function
+  | <:expr< $e1$, $e2$ >> -> split_by_comma e1 @ split_by_comma e2
+  | <:expr< >> -> []
+  | <:expr< $e$ >> -> [e]
+
+let deconstr_tydef tp =
+  let rec strip_private = function
+    | TyPrv (_, ctyp) -> strip_private ctyp
+    | ctyp -> ctyp
+  in
+  match strip_private tp with
+  | TyNil loc -> `Nil loc 
+  | TyMan (loc, ctyp, ctyp') -> `Mani (loc, ctyp, ctyp') 
+  | TyRec (loc ,ctyp) ->
+      let fields = List.map (function
+        | TyCol (loc, TyId(_, lab_id), ctyp) -> loc, lab_id, ctyp
+        | _ -> assert false) (list_of_ctyp ctyp [] )
+      in
+      `Record (loc, fields) 
+  | TySum (loc, ctyp) ->
+      let cases = List.map (function
+        | <:ctyp@loc< $id:id$ of $ctyp$ >> -> loc, id, list_of_ctyp ctyp []
+        | <:ctyp@loc< $id:id$ >> -> loc, id, []
+        | _ -> assert false) (list_of_ctyp ctyp []) in
+      `Sum (loc, cases) 
+  | TyVrnEq (loc, ctyp)
+  | TyVrnSup (loc, ctyp)
+  | TyVrnInf (loc, ctyp) ->
+      let cases = List.map (function
+        | <:ctyp@loc< `$idstr$ of $ctyp$ >> -> loc, idstr, list_of_ctyp ctyp []
+        | <:ctyp@loc< `$idstr$ >> -> loc, idstr, []
+        | _ -> assert false) (list_of_ctyp ctyp [])
+      in
+      `Variant (loc, cases)
+  | ctyp -> `Alias (loc_of_ctyp ctyp, ctyp)
+
+let deconstr_variant_type = function
+  | TyVrnEq (loc, ctyp) -> (* [ = t ] *)
+      let cases = List.map (function
+        | <:ctyp@loc< `$idstr$ of $ctyp$ >> -> loc, idstr, list_of_ctyp ctyp []
+        | <:ctyp@loc< `$idstr$ >> -> loc, idstr, []
+        | _ -> assert false) (list_of_ctyp ctyp [])
+      in
+      loc, cases
+  | _ -> assert false
+
+let deconstr_object_type = function
+  | TyObj (ty_loc, ctyp, flag) ->
+      let fields = List.map (function
+        | TyCol (_loc, TyId(loc, id), ctyp) -> loc, id, ctyp
+        | _ -> assert false) (list_of_ctyp ctyp []) 
+      in
+      ty_loc, fields, flag
+  | _ -> assert false
+
+let type_definitions_are_recursive rec_ tds = 
+  rec_ &&
+    List.exists (function
+      | TyDcl (_, name, _, _, _) -> Gen.type_is_recursive name tds
+      | _ -> assert false) 
+    (list_of_ctyp tds [])
+
+
+
+(** { 6 Type construction } *)
+
+(** (p1, p2, .., pn) name *)
+let create_param_type : ctyp list -> string -> ctyp = fun params name ->
+  List.fold_left (fun st x -> TyApp (_loc, st, x)) <:ctyp< $lid: name$ >> params 
+
+(** p1 ... pn . ty *)
+let create_for_all : ctyp list -> ctyp -> ctyp = fun params ty -> match params with
+  | [] -> ty
+  | x::xs -> TyPol (_loc, List.fold_right (fun x st -> TyApp (_loc, st, x)) xs x, ty)
+
+let create_object_type : bool -> (string * ctyp) list -> ctyp = fun poly fields ->
+  let fields = 
+    List.map (fun (lab, ctyp) -> 
+      let id = <:ident< $lid:lab$ >> in
+      TyCol(_loc, TyId(_loc, id), ctyp)) fields
+  in
+  TyObj (_loc, tySem_of_list fields, if poly then RvRowVar else RvNil )
+
 (** e1, e2, ..., en => (e1,...,en) 
     Do not use this for variant creations, since variants are curried in P4.
 *)
          rbSem_of_list (List.map (fun (l,e) -> RbEq(_loc, l,e)) label_exprs), 
          ExNil _loc)
 
-let create_top_let : bool -> binding list -> str_item = fun rec_ binds ->
-  let binds = 
-    let rec create_binds = function
-      | [] -> BiNil _loc
-      | x::xs -> BiAnd (_loc, x, create_binds xs)
-    in
-    create_binds binds 
-  in
-  if rec_ then <:str_item< let rec $binds$ >>
-  else <:str_item< let $binds$ >>
+(** l1,e1, ... ln,en => object method l1 = e1; ...; method ln = en end *)
+let create_object : (string * expr) list -> expr = fun label_exprs -> 
+  ExObj (_loc, 
+         PaNil _loc,
+         crSem_of_list (List.map (fun (l,e) -> <:class_str_item< method $l$ = $e$ >>) label_exprs))
 
-(** [strip_flags cty] removes mutable and private flags *)
-let rec strip_field_flags = function
-  | TyMut (_, cty) | TyPrv (_, cty) -> strip_field_flags cty
-  | cty -> cty
 
-(** forget the ident locations *)
-let rec strip_ident_loc : ident -> ident = function
-  | IdAcc(_, id1, id2) -> IdAcc(_loc, strip_ident_loc id1, strip_ident_loc id2)
-  | IdApp(_, id1, id2) -> IdApp(_loc, strip_ident_loc id1, strip_ident_loc id2)
-  | IdLid(_, n) -> IdLid(_loc, n)
-  | IdUid(_, n) -> IdUid(_loc, n)
-  | IdAnt(_, n) -> IdAnt(_loc, n)
 
-(* CR jfuruse: bug: a.B.c.D is accepted *)    
-let convert_path ss =
-  let create = function
-    | "" -> assert false
-    | x -> match x.[0] with
-      | 'a'..'z' -> <:ident< $lid:x$ >> 
-      | 'A'..'Z' -> <:ident< $uid:x$ >>
-      | _ -> assert false
-  in
-  let rec concat = function
-    | [x] -> x
-    | x::xs -> <:ident< $x$ . $concat xs$ >>
-    | [] -> assert false
-  in
-  concat (List.map create ss)
-
-let name_of_ident = function
-  | IdUid (_, name) | IdLid (_, name) -> name
-  | _ -> assert false
-
-let type_definitions_are_recursive rec_ tds = 
-  rec_ &&
-    List.exists (function
-      | TyDcl (_, name, _, _, _) -> Gen.type_is_recursive name tds
-      | _ -> assert false) 
-    (list_of_ctyp tds [])

File pa/tctools.mli

 open Camlp4.PreCast.Ast
 
+(** { 6 Tools } *)
+
 val from_one_to : int -> int list
 (** [ from_one_to n = [1; 2; ..; n] ] *)
 
+
+
+(** { 6 Idents and Paths } *)
+
 val mk_idents : string -> int -> ident list
 (** [mk_idents name n] creates idents from name1 to namen *) 
 
 val patt_of_id : ident -> patt
 (** [expr_of_id id] and [patt_of_id id] create an expr or patt of [id] correspondingly *)
 
+
+val strip_locs_of_ident : ident -> ident
+(** strips off location information to normalize [ident] *)
+
+val same_idents : ident -> ident -> bool
+(** returns true if two idents are the same, ignoring the locations *)
+
+(** { 6 Tvars } *)
+
 val patt_of_tvar : ctyp -> patt
 (** [patt_of_tvar tv] creates a pattern variable for a type variable [tv] *)
 val expr_of_tvar : ctyp -> expr
 (** [expr_of_tvar tv] creates an expression variable for a type variable [tv] *)
 
+
+
+
+(** { 6 Creators } *)
+
 val create_patt_app : patt -> patt list -> patt
 (** [create_patt_app const args] creates a pattern of variant constructor like 
     const (arg1,..,argn) *)
 val create_record : (ident * expr) list -> expr
 (** l1,e1, ... ln,en => { l1:e1; ...; ln:en } *)
 
+val create_object : (string * expr) list -> expr
+(** l1,e1, ... ln,en => object method l1 = e1; ...; method ln = en end *)
+
 val create_top_let : bool -> binding list -> str_item
 
+
+
 (** { 6 Concatenations } *)
 
 val concat_let_bindings : binding list -> binding
 val concat_str_items : str_item list -> str_item
 val concat_sig_items : sig_item list -> sig_item
 
+
+
+
+(** { 6 Deconstruction } *)
+
+val split_by_comma : expr -> expr list
+
+val deconstr_tydef : ctyp 
+  -> [> `Alias of Loc.t * ctyp
+     | `Mani of Loc.t * ctyp * ctyp
+     | `Nil of Loc.t
+     | `Record of Loc.t * (loc * ident * ctyp) list
+     | `Sum of Loc.t * (loc * ident * ctyp list) list
+     | `Variant of Loc.t * (loc * string * ctyp list) list ]
+
+val deconstr_variant_type : ctyp -> loc * (loc * string * ctyp list) list
+
+val deconstr_object_type : ctyp -> loc * (loc * ident * ctyp) list * row_var_flag
+
+val type_definitions_are_recursive : bool -> ctyp -> bool
+
+
 (** { 6 Type construction } *)
 
 val create_param_type : ctyp list -> string -> ctyp
 val create_for_all : ctyp list -> ctyp -> ctyp
 (** p1 ... pn . ty *)
 
+val create_object_type : bool (** poly or not *) -> (string * ctyp) list -> ctyp
+(** < x : t; ...; .. > *)
+
+
+
 (** { 6 Strippers } *)
 
 val strip_field_flags : ctyp -> ctyp
 val strip_ident_loc : ident -> ident
 (** strip location *)
 
-(** { 6 Recursion } *)
 
-val type_definitions_are_recursive : bool -> ctyp -> bool
-(** Checks type declaration (list of TyDcl ...) has recursive components.
-    Not quite sure it is correct implementation or not. *)
+

File pa/tests/OMakefile

     camlp4o -I $(OCAMLFIND_DESTDIR)/type_conv pa_type_conv.cma ../pa_meta_conv.cma  -printer Camlp4OCamlPrinter $< > $@
 
 .DEFAULT: test.out.ml test_mli.out.mli test_multi.out.ml test_record_arg.out.ml test_rest.out.ml
-.DEFAULT: test_optional.out.ml
+.DEFAULT: test_optional.out.ml test_closed_variants.out.ml
 
+

File pa/tests/test_closed_variants.ml

+type t = [ `Foo of int | `Bar as "BAR" ] with conv(json)
+

File pa/tests/test_object.ml

+type t = < x : int > with conv(json)
+

File pa/tests/test_rest.ml

-type t = { a : int; b : float; c (: Leftovers :) : (string * Json.t) list  } with conv(json)
+type t = { a : int; b : float; c : Json.t mc_leftovers } with conv(json)
 
 type t = { d : int; e : Json.t mc_leftovers } with conv(json)
 

File pa/tests/test_sub_variant.ml

+type t = int * [ `Foo of int | `Bar as "BAR" ] with conv(json)
+