Commits

camlspotter  committed 24c5fa0

object type support

  • Participants
  • Parent commits 6ea5a09
  • Branches dev

Comments (0)

Files changed (8)

 0.11.0
 -------------
 
-<<<<<<< local
-- Added closed polymorphic variant type support
-- Added object conversions via record types
-||||||| base
-=======
-- Added closed polymorphic variant type support
->>>>>>> other
-- 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.
+- Bug fixes
 
 0.10.0
 -------------

File pa/OMakefile

     type_conv
 
 FILES[]=
-    ctyp_omap_4_00_1
     tctools
     pa_meta_conv
 

File pa/ctyp_omap_4_00_1.ml

-open Camlp4
-open PreCast
-open Ast
-
-class virtual omap =
-  object ((self : 'self))
-    method virtual list :
-      'a1.
-        ('self -> 'a1 -> ('self * 'a1)) -> 'a1 list -> ('self * ('a1 list))
-    method ctyp : ctyp -> ('self * ctyp) =
-      fun __value ->
-        match __value with
-        | TyNil __x1 -> (self, __value)
-        | TyAli (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyAli (__y1, __y2, __y3)))
-        | TyAny __x1 -> (self, __value)
-        | TyApp (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyApp (__y1, __y2, __y3)))
-        | TyArr (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyArr (__y1, __y2, __y3)))
-        | TyCls (__x1, __x2) -> (self, __value)
-        | TyLab (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let __y2 = __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyLab (__y1, __y2, __y3)))
-        | TyId (__x1, __x2) -> (self, __value)
-        | TyMan (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyMan (__y1, __y2, __y3)))
-        | TyDcl (__x1, __x2, __x3, __x4, __x5) ->
-            let __y1 = __x1 in
-            let __y2 = __x2 in
-            let (self, __y3) = self#list (fun self -> self#ctyp) __x3 in
-            let (self, __y4) = self#ctyp __x4 in
-            let (self, __y5) =
-              self#list
-                (fun self (((__x1, __x2) as __value)) ->
-                   let (self, __y1) = self#ctyp __x1 in
-                   let (self, __y2) = self#ctyp __x2
-                   in
-                     (self,
-                      (if (__x2 == __y2) && (__x1 == __y1)
-                       then __value
-                       else (__y1, __y2))))
-                __x5
-            in
-              (self,
-               (if
-                  (__x2 == __y2) &&
-                    ((__x3 == __y3) &&
-                       ((__x4 == __y4) && ((__x5 == __y5) && (__x1 == __y1))))
-                then __value
-                else TyDcl (__y1, __y2, __y3, __y4, __y5)))
-        | TyObj (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let __y3 = __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyObj (__y1, __y2, __y3)))
-        | TyOlb (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let __y2 = __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyOlb (__y1, __y2, __y3)))
-        | TyPol (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyPol (__y1, __y2, __y3)))
-        | TyTypePol (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyTypePol (__y1, __y2, __y3)))
-        | TyQuo (__x1, __x2) -> (self, __value)
-        | TyQuP (__x1, __x2) -> (self, __value)
-        | TyQuM (__x1, __x2) -> (self, __value)
-        | TyAnP __x1 -> (self, __value)
-        | TyAnM __x1 -> (self, __value)
-        | TyVrn (__x1, __x2) -> (self, __value)
-        | TyRec (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyRec (__y1, __y2)))
-        | TyCol (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyCol (__y1, __y2, __y3)))
-        | TySem (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TySem (__y1, __y2, __y3)))
-        | TyCom (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyCom (__y1, __y2, __y3)))
-        | TySum (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TySum (__y1, __y2)))
-        | TyOf (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyOf (__y1, __y2, __y3)))
-        | TyAnd (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyAnd (__y1, __y2, __y3)))
-        | TyOr (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyOr (__y1, __y2, __y3)))
-        | TyPrv (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyPrv (__y1, __y2)))
-        | TyMut (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyMut (__y1, __y2)))
-        | TyTup (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyTup (__y1, __y2)))
-        | TySta (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TySta (__y1, __y2, __y3)))
-        | TyVrnEq (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyVrnEq (__y1, __y2)))
-        | TyVrnSup (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyVrnSup (__y1, __y2)))
-        | TyVrnInf (__x1, __x2) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2
-            in
-              (self,
-               (if (__x2 == __y2) && (__x1 == __y1)
-                then __value
-                else TyVrnInf (__y1, __y2)))
-        | TyVrnInfSup (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyVrnInfSup (__y1, __y2, __y3)))
-        | TyAmp (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyAmp (__y1, __y2, __y3)))
-        | TyOfAmp (__x1, __x2, __x3) ->
-            let __y1 = __x1 in
-            let (self, __y2) = self#ctyp __x2 in
-            let (self, __y3) = self#ctyp __x3
-            in
-              (self,
-               (if (__x2 == __y2) && ((__x3 == __y3) && (__x1 == __y1))
-                then __value
-                else TyOfAmp (__y1, __y2, __y3)))
-        | TyPkg (__x1, __x2) -> (self, __value)
-        | TyAnt (__x1, __x2) -> (self, __value)
-  end
-  
-

File pa/pa_meta_conv.ml

 
 (* code generators ******************************************************)
 
-module RecordObject(A : sig
-  val target_type_path : ident
-  val module_path : ident
-  val conv_name : string
-end) = struct
-
-  let types = fun _rec_ tds ->
-    let _loc = Ast.loc_of_ctyp tds in
-    let decls = list_of_ctyp tds [] in
-    let decls = List.map (function
-      | TyDcl (loc, name, _params, definition, _constraints) as td -> 
-          loc, name, deconstr_tydef definition, td
-      | _ -> assert false) decls
-    in
-    let renames = List.map (fun (_, name, _, _) ->
-      name, name ^ "_object") decls
-    in
-    rename (function
-      | (TyId (loc, ident) as ctyp) -> 
-          let name = name_of_ident ident in
-          begin try 
-                  <:ctyp@loc< $lid:List.assoc name renames$ >>
-            with Not_found -> ctyp
-          end
-      | ctyp -> ctyp) tds
-
-(*
-  (* 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.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) cty = 
-    match deconstr_tydef cty with
-    | `Record  (_, fields) -> 
-        <:sig_item<
-          val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
-          val $lid: A.conv_name ^ "_of_" ^ name ^ "_object" $ : $func_object_type params fields$
-        >>
-    | `Variant _ | `Sum _ | `Alias _ -> 
-        <:sig_item<
-          val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
-        >>
-    | _ -> assert false
-  
-  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
-*)
-
-
-
-end
-
 module Encode(A : sig
   val target_type_path : ident
   val module_path : ident
          (create_param_type params name)
          <:ctyp< $id:target_type_path$ >>)
 
+(*
   let func_object_type params fields = 
     create_for_all params 
       (dispatch_type params 
          (create_object_type true (List.map (fun (_loc, id, ctyp) -> 
            name_of_ident id, strip_field_flags ctyp) fields))
          <:ctyp< $id:target_type_path$ >>)
+*)
   
   let dcl _loc name (params : ctyp list) exp =
     <:binding<
         $Gen.abstract _loc (List.map patt_of_tvar params) exp$
     >>
   
+(*
   let dcl_object _loc name (params : ctyp list) fields exp =
     <:binding<
       $lid: A.conv_name ^ "_of_" ^ name ^ "_object"$ : $func_object_type params fields$ = 
         $Gen.abstract _loc (List.map patt_of_tvar params) exp$
     >>
+*)
   
   let rec gen_ctyp : ctyp -> expr = function
     | TyId (loc, id) ->  (* int *)
              [create_list (List.map2 (fun id ctyp ->
                <: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 tyd_loc name params _loc cty = 
-    let f = gen_ctyp cty in
-    [ dcl tyd_loc name params <:expr< fun __value -> $f$ __value >> ]
-    
+  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)$ >>
+
+  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 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
       in
       <:match_case< $ patt $ -> $ exp $ >>
     in
-    [dcl tyd_loc name params <:expr< fun __value -> match __value with $mcOr_of_list (List.map case cases)$ >>]
+    [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 sem = interprete_record_field_annotation loc lab_id ctyp in
       match sem with
       | { leftovers = true; _ } ->
-          fields, Some (<:expr< __value.$id:lab_id$ >>, 
-                        <:expr< __value#$name_of_ident lab_id$ >>) 
+          fields, Some <:expr< __value.$id:lab_id$ >>
       | { name = s; optional = true; _ } ->
-          (<:expr< match __value.$id:lab_id$ with 
+          <:expr< match __value.$id:lab_id$ with 
                    | None -> None 
-                   | Some v -> Some ($str:s$, $f$ v) >>,
-           <:expr< match __value#$name_of_ident lab_id$ with 
-                   | None -> None 
-                   | Some v -> Some ($str:s$, $f$ v) >>
-          ) :: fields,
-        rest
+                   | Some v -> Some ($str:s$, $f$ v) >>    
+          :: fields,
+          rest
       | { name = s; _ } ->
-          (<:expr< Some ($str:s$, $f$ __value.$id:lab_id$) >>,
-           <:expr< Some ($str:s$, $f$ __value#$name_of_ident lab_id$) >>
-          ) :: fields,
+          <:expr< Some ($str:s$, $f$ __value.$id:lab_id$) >>
+          :: fields,
         rest) field_types ([], None)
     in
-    let record_fields = List.map fst fields in
-    let record_exp = <:expr< Meta_conv.Internal.list_filter_map (fun x -> x) $create_list record_fields$ >> in
-    let record_exp = match rest with
-      | None -> record_exp 
-      | Some (e,_) -> <:expr< $record_exp$ @ $e$ >>
+    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
-
-    let object_fields = List.map snd fields in
-    let object_exp = <:expr< Meta_conv.Internal.list_filter_map (fun x -> x) $create_list object_fields$ >> in
-    let object_exp = match rest with
-      | None -> object_exp 
-      | Some (_,e) -> <:expr< $object_exp$ @ $e$ >>
-    in
-    [ dcl tyd_loc name params <:expr< (fun __value -> $id:module_path$.Encode.record $record_exp$) >>;
-      dcl_object tyd_loc name params field_types <:expr< (fun __value -> $id:module_path$.Encode.record $object_exp$) >>;
+    [ dcl tyd_loc name params <:expr< (fun __value -> $id:module_path$.Encode.record $exp$) >>;
     ]
     
   let variants tyd_loc name params _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
-    [ dcl tyd_loc name params <:expr< fun __value -> match __value with $mcOr_of_list (List.map case cases)$ >> ]
+    [ dcl tyd_loc name params (gen_variants tyd_loc cases) ]
   
   (******************* kind of template *)
   
     in
     create_top_let recursive binds
 
-  let dcl_sg _loc name (params : ctyp list) cty = 
-    match deconstr_tydef cty with
-    | `Record  (_, fields) -> 
-        <:sig_item<
-          val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
-          val $lid: A.conv_name ^ "_of_" ^ name ^ "_object" $ : $func_object_type params fields$
-        >>
-    | `Variant _ | `Sum _ | `Alias _ -> 
-        <:sig_item<
-          val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
-        >>
-    | _ -> assert false
+  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 func_type     = gen_func_type dispatch_type
   let func_type_exn = gen_func_type dispatch_type_exn
   
-  let gen_func_object_type disp params fields = 
-    create_for_all params 
-      (disp params
-        <:ctyp< $id:target_type_path$ >>
-        (create_object_type false (List.map (fun (_loc, id, ctyp) -> 
-          name_of_ident id, strip_field_flags ctyp) fields)))
-
-  let func_object_type     = gen_func_object_type dispatch_type
-  let func_object_type_exn = gen_func_object_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
-  
+    
+  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 labels, fields, rest = List.fold_right (fun (loc, lab_id, ctyp) (labs, st, rest) ->
+      let sem = interprete_record_field_annotation 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 None (*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.record __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$ = 
         >> ]
 
   let alias tyd_loc name params _loc cty = 
-    let f = gen_ctyp cty in
+    let f = gen_ctyp ~type_name: name cty in
     dcl tyd_loc name params <:expr< fun __value -> $f$ __value >>
   ;;
 
               $ 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 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$ 
       >>
       match sem with
       | { leftovers = true; _ }-> 
           labs, (lab_id, <:expr< `Ok unknown_fields >>) :: st, Some lab_id
-      | { name; optional = true; _ } -> 
+      | { name=key; optional = true; _ } -> 
           let conv = gen_ctyp ctyp in
-          name :: labs,
+          key :: labs,
           (lab_id, 
-           <:expr< Meta_conv.Internal.field_assoc_optional $str:name$ __value $str:name$ fields $conv$ >>)
+           <:expr< Meta_conv.Internal.field_assoc_optional __name __value $str:key$ fields $conv$ >>)
           :: st,
           rest
-      | { name; _ } -> 
+      | { name=key; _ } -> 
           let conv = gen_ctyp ctyp in
-          name :: labs,
+          key :: labs,
           (lab_id, 
-           <:expr< Meta_conv.Internal.field_assoc $str:name$ __value $str:name$ fields $conv$ >>)
+           <:expr< Meta_conv.Internal.field_assoc __name __value $str:key$ fields $conv$ >>)
           :: st,
           rest) field_types ([], [], None)
     in
         (create_record (List.map (fun (id, _) -> id, expr_of_id id) fields))
     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
-    
     let meta_decoder = 
       dcl_meta 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:name$ __value unknown_fields (fun () -> 
+        $unknown_fields_check$ __name __value unknown_fields (fun () -> 
           $the_builder$) 
         >>
     in
       
-    let record_decoder = 
+    let decoder = 
       [ `NoRec <:binding<
           $lid: name ^ "_of_" ^ A.conv_name$ : $func_type params name$ = fun x ->
           $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name$ $the_record$ x
         >> ]
     in
 
-    let object_decoder = 
-      [ `NoRec <:binding<
-          $lid: name ^ "_object_of_" ^ A.conv_name$ : $func_object_type params field_types$ = fun x ->
-          $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name$ $the_object$ x
-          >>; 
-        `NoRec <:binding<
-          $lid: name ^ "_object_of_" ^ A.conv_name ^ "_exn"$ : $func_object_type_exn params field_types$ = fun x ->
-          $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name ^ "_exn"$ $the_object$ x
-        >> ]
-    in
-
-    meta_decoder @ record_decoder @ object_decoder
+    (* CR jfuruse: We have no longer object_decoder, so meta_decoder and decoder  can be unified *)
+    meta_decoder @ decoder
 
   let variants tyd_loc name params _loc cases = 
-    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 ] *)
-      let case = <: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 
-                $str:name$ $str:id_name$ $int:string_of_int len$ (List.length l)
-                __value
-          end
-        >> 
-      in
-      case
-    in
-    let default = <:match_case<
-      name, l -> 
-        Meta_conv.Internal.variant_unknown_tag_error 
-          $str:name$ name __value
-      >>
-    in
-    let cases = List.map case cases @ [ default ] in
-    dcl tyd_loc name params 
-      <:expr< fun __value -> 
-        match $id:module_path$.Decode.poly_variant __value with 
-          $mcOr_of_list cases$ 
-      >>
+    dcl tyd_loc name params (gen_variants ~type_name:name _loc cases)
 
   (******************* kind of template *)
   

File pa/tctools.ml

 
 
 
+(** { 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< $e$ >> -> [e]
 
 let deconstr_tydef tp =
-  let alias loc ctyp = `Alias (loc, ctyp) in
-  let sum 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) 
+  let rec strip_private = function
+    | TyPrv (_, ctyp) -> strip_private ctyp
+    | ctyp -> ctyp
   in
-  let record 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) 
-  in
-  let variants 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)
-  in
-  let mani loc ctyp ctyp' = `Mani (loc, ctyp, ctyp') in
-  let nil loc = `Nil loc in
-  Gen.switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil tp
+  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 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 Recursion } *)
-
-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 traversal } *)
-
-class ctyp_map = object (self : 'self)
-  inherit Ctyp_omap_4_00_1.omap
-   method list : 'a1. ('self -> 'a1 -> ('self * 'a1)) -> 'a1 list -> ('self * ('a1 list)) = fun f xs ->
-     List.fold_left (fun (self, xs) x ->
-       let self, x' = f self x in
-       self, x' :: xs) (self, []) xs
-end
-
-class rename f = object (self)
-  inherit ctyp_map as parent
-  method! ctyp = function
-(*  | TyCls (loc, ident) -> self, f (`Cls (loc, ident)) *)
-    | (TyId  _ | TyDcl _ as ctyp) -> 
-        let self, ctyp = parent#ctyp ctyp in
-        self, f ctyp
-    | ctyp -> (self, ctyp)
-end
-
-let rename f ctyp = snd ((new rename f)#ctyp ctyp)

File pa/tctools.mli

      | `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 } *)
 
 
 
-(** { 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. *)
-
-val rename : (ctyp -> ctyp) -> ctyp -> ctyp

File pa/tests/test_object.ml

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

File pa/tests/test_sub_variant.ml

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