Commits

camlspotter  committed 9f05fe1

first crude record object conversion

  • Participants
  • Parent commits 51ce12b

Comments (0)

Files changed (3)

File pa/pa_meta_conv.ml

   
   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 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<
+      $lid: A.conv_name ^ "_of_" ^ name$ : $func_type params name$ = 
+        $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 *)
         <:expr@loc< $id: change_id (fun s -> A.conv_name ^ "_of_" ^ s) id$ >>
              ) ids ctyps)])
     | _ -> assert false
     
-  let alias _name _tyd_loc _loc cty = 
+  let alias tyd_loc name params _loc cty = 
     let f = gen_ctyp cty in
-    <:expr< fun __value -> $f$ __value >>
+    [ 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 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 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 
       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< fun __value -> match __value with $mcOr_of_list (List.map case cases)$ >>]
+  
+  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 loc lab_id ctyp in
+      match sem with
+      | { leftovers = true; _ } ->
+          fields, Some (<:expr< __value.$id:lab_id$ >>, 
+                        <:expr< __value#$name_of_ident lab_id$ >>) 
+      | { name = s; optional = true; _ } ->
+          (<: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
+      | { name = s; _ } ->
+          (<:expr< Some ($str:s$, $f$ __value.$id:lab_id$) >>,
+           <:expr< Some ($str:s$, $f$ __value#$name_of_ident 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
-    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$ >>
+    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$ >>
     in
 
-    <:expr< fun __value -> $id:module_path$.Encode.record $exp$ >>
+    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$) >>;
+    ]
     
-  let variants _name _tyd_loc _loc ctyp = 
-    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
-    let case loc idstr ctyp =
+  let variants tyd_loc name params _loc cases = 
+    let case (loc, idstr, ctyps) =
       let id_name = interprete_variant_annotation loc idstr in
-
-      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
       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 
       in
       <:match_case< $ patt $ -> $ exp $ >>
     in
-    let cases = 
-      List.map (function
-        | <:ctyp@loc< `$idstr$ >> -> case loc idstr (TyNil _loc)
-        | <:ctyp@loc< `$idstr$ of $ctyp$ >> -> case loc idstr ctyp
-        | _ -> assert false
-      ) constrs 
-    in
-    <:expr< fun __value -> match __value with $mcOr_of_list cases$ >>
-  
-  (** 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$ >>)
+    [ dcl tyd_loc name params <:expr< fun __value -> match __value with $mcOr_of_list (List.map case cases)$ >> ]
   
   (******************* kind of template *)
   
-  let def name loc cty =
-    let variants = variants name loc 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
+    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 =
-    <:sig_item<
-      val $lid: A.conv_name ^ "_of_" ^ name $ : $func_type params name$
-    >>
+  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
   
   open A
 
+  (** 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))
+  
+  let func_object_type params fields = 
+    create_for_all params (dispatch_type 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_exn params fields = 
+    create_for_all params (dispatch_type_exn 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 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$ >>
         >>
     | _ -> assert false
   
-  let alias _name _tyd_loc _loc cty = 
+  let dcl _loc name (params : ctyp list) body =
+    <:binding<
+      $lid: name ^ "_of_" ^ A.conv_name$ : $func_type params name$ = 
+      $Gen.abstract _loc (List.map patt_of_tvar params) body$
+      >>, 
+    <: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 dcl_object _loc name (params : ctyp list) fields body =
+    <:binding<
+      $lid: name ^ "_object_of_" ^ A.conv_name$ : $func_object_type params fields$ = 
+      $Gen.abstract _loc (List.map patt_of_tvar params) body$
+    >>,
+    <:binding<
+      $lid: name ^ "_object_of_" ^ A.conv_name ^ "_exn"$ : $func_object_type_exn params fields$ = 
+        $Gen.abstract _loc (List.map patt_of_tvar params) <:expr<
+          fun v -> 
+            match $ Gen.apply _loc <:expr< $lid: name ^ "_object_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 cty in
-    <:expr< fun __value -> $f$ __value >>
+    [ 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 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
 
           $str: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 cases = List.map case cases @ [ default ] in
+    [ dcl tyd_loc name params
+      <:expr< fun __value -> 
+        match $id:module_path$.Decode.variant __value with 
+          $mcOr_of_list cases$ 
+      >>
+    ]
   
-  let record ty_name tyd_loc _loc ctyp = 
+  let record tyd_loc ty_name params _loc field_types = 
     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 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; 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) 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 = 
       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 -> 
-      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$) 
-    >>
+    let record_decoder = 
+      dcl tyd_loc ty_name params <:expr< fun __value -> 
+        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$) 
+        >>
+    in
+
+    let the_object = 
+      let final = create_object (List.map (fun (id, _) -> name_of_ident id, expr_of_id id) fields) in
+      binds (List.map fst fields) (List.map snd fields) final
+    in
+
+    let object_decoder = 
+      dcl_object tyd_loc ty_name params field_types <:expr< fun __value -> 
+        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_object$) 
+        >>
+    in
     
-  let variants name _tyd_loc _loc ctyp = 
-    let constrs = list_of_ctyp ctyp [] in (* decompose TyOr *)
-    let case loc idstr ctyp =
+    [ record_decoder; object_decoder ]
+
+  let variants tyd_loc name params _loc cases = 
+    let case (loc, idstr, ctyps) =
       let id_name = interprete_variant_annotation loc idstr in
 
-      let ctyps = list_of_ctyp ctyp [] in (* decompose TyAnd *)
       let len = List.length ctyps in
       let ids = mk_idents "__x" len in
 
           $str:name$ name __value
       >>
     in
-    let cases = 
-      List.map (function
-        | <:ctyp@loc< `$idstr$ of $ctyp$ >> -> case loc idstr ctyp
-        | <:ctyp@loc< `$idstr$ >> -> case loc idstr (TyNil _loc)
-        | _ -> assert false
-      ) constrs @ [ default ]
-    in
-    <:expr< fun __value -> 
-      match $id:module_path$.Decode.poly_variant __value with 
-        $mcOr_of_list cases$ 
-    >>
-  
-  (** 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))
+    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$ 
+      >>
+    ]
   
   (******************* kind of template *)
   
-  let def name loc cty =
-    let variants = variants name loc 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 *)
+  (* 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.map (function
-        | TyDcl (loc, name, params, def, _constraints) -> 
-            dcl loc name params def
-        | _ -> assert false) decls
+      let binds = List.flatten (List.map (function
+        | TyDcl (loc, name, params, definition, _constraints) -> def loc name params definition
+        | _ -> assert false) decls)
       in
+      (* exn versions must be defined later *)
       [ create_top_let recursive (List.map fst binds);
         create_top_let recursive (List.map snd binds) ]
 

File pa/tctools.ml

 let expr_of_id : ident -> expr = fun id -> <:expr< $id:id$ >>
 let patt_of_id : ident -> patt = fun id -> <:patt< $id:id$ >>
 
+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) 
+  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
+
 (** (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 
   | [] -> 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 )
+
 (** 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)
          rbSem_of_list (List.map (fun (l,e) -> RbEq(_loc, l,e)) label_exprs), 
          ExNil _loc)
 
+(** 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))
+
 let create_top_let : bool -> binding list -> str_item = fun rec_ binds ->
   let binds = 
     let rec create_binds = function

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 } *)
+
 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 *)
 
+(** { 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 Type definition deconstruction } *)
+
+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 ]
+
 (** { 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 Type declaration deconstruction } *)
+
 (** { 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