Commits

camlspotter committed bb4a0d2 Merge

merged with dev

Comments (0)

Files changed (7)

 -------------
 
 - 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).
+
 - Bug fixes
 
 0.10.0

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

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'

pa/pa_meta_conv.ml

       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 ******************************************************)
     (* 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
+      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$ >>
     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
+      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$ >>
     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 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; _ }-> 
                   >> $
         >> ]
 
-  let dcl_meta _loc name (params : ctyp list) body =
-    [ `MayRec <:binding<
-          $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name$ __f = 
-          $Gen.abstract _loc (List.map patt_of_tvar params) body$
-          >>; 
-      `NoRec  <:binding<
-          $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name ^ "_exn"$ __f = 
-          $Gen.abstract _loc (List.map patt_of_tvar params) <:expr<
-            fun v -> 
-              match $ Gen.apply _loc <:expr< $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name$ __f >> (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 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 loc lab_id ctyp in
+      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; _ }-> 
 
     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_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 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$ __name __value unknown_fields (fun () -> 
-          $the_builder$) 
-        >>
+    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 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
-          >>;  
-        `NoRec <:binding<
-          $lid: name ^ "_of_" ^ A.conv_name ^ "_exn"$ : $func_type_exn params name$ = fun x ->
-          $lid: "meta_" ^ name ^ "_of_" ^ A.conv_name ^ "_exn"$ $the_record$ x
-        >> ]
+*)
+    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
 
-    (* CR jfuruse: We have no longer object_decoder, so meta_decoder and decoder  can be unified *)
-    meta_decoder @ decoder
+    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$ __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)
   | 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 } *)
 
 (** [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 } *)
 

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)