Commits

camlspotter committed b66a3e8

type name is now passed to constr and deconstr

Comments (0)

Files changed (5)

   *)
   module Constr = struct
     let tuple ts = Array ts
-    let variant tag = function
+    let variant _tyname tag = function
       | [] -> String tag
       | ts -> Object [tag, Array ts]
-    let record tag_ts  = Object tag_ts
+    let record _tyname tag_ts  = Object tag_ts
     let poly_variant = variant (* We use the same construction as variants *)
     let object_ = record (* We use the same construction as records *)
   end
           (* Otherwise, it is not interpretable as a tuple, so raise an exception *)
           failwith "Array expected for tuple" 
   
-    let variant = function 
+    let variant _tyname = function 
       | String tag -> tag, [] 
       | Object [tag, Array ts] -> tag, ts
       | _ -> failwith "Object expected for variant"
   
-    let record = function
+    let record _tyname = function
       | Object alist -> alist
       | _ -> failwith "Object expected for record"
   
 let json_of_mc_lazy_t = Helper.of_mc_lazy_t
 let mc_lazy_t_of_json = Helper.mc_lazy_t_of
 
-let json_of_mc_fields enc xs = Constr.record (List.map (fun (name, a) -> (name, enc a)) xs)
-let mc_fields_of_json dec = Helper.mc_fields_of (function Object js -> Some js | _ -> None) dec
+let json_of_mc_fields enc xs = 
+  Constr.record "mc_fields" (List.map (fun (name, a) -> (name, enc a)) xs)
+
+let mc_fields_of_json dec = 
+  Helper.mc_fields_of (function Object js -> Some js | _ -> None) dec
   module DeconstrDecoder = struct
 
     let tuple ?trace        = decoder_of_deconstr Deconstr.tuple ?trace
-    let variant ?trace      = decoder_of_deconstr Deconstr.variant ?trace
-    let poly_variant ?trace = decoder_of_deconstr Deconstr.poly_variant ?trace
-    let record ?trace       = decoder_of_deconstr Deconstr.record ?trace
-    let object_ ?trace      = decoder_of_deconstr Deconstr.object_ ?trace
+    let variant tyname      ?trace = decoder_of_deconstr (Deconstr.variant tyname) ?trace
+    let poly_variant tyname ?trace = decoder_of_deconstr (Deconstr.poly_variant tyname) ?trace
+    let record tyname    ?trace   = decoder_of_deconstr (Deconstr.record tyname) ?trace
+    let object_ tyname    ?trace  = decoder_of_deconstr (Deconstr.object_ tyname) ?trace
       
     let tuple_exn ?trace        = decoder_exn_of_deconstr Deconstr.tuple ?trace
-    let variant_exn ?trace      = decoder_exn_of_deconstr Deconstr.variant ?trace
-    let poly_variant_exn ?trace = decoder_exn_of_deconstr Deconstr.poly_variant ?trace
-    let record_exn ?trace       = decoder_exn_of_deconstr Deconstr.record ?trace
-    let object_exn ?trace       = decoder_exn_of_deconstr Deconstr.object_ ?trace
+    let variant_exn tyname  ?trace    = decoder_exn_of_deconstr (Deconstr.variant tyname) ?trace
+    let poly_variant_exn tyname ?trace = decoder_exn_of_deconstr (Deconstr.poly_variant tyname) ?trace
+    let record_exn tyname   ?trace     = decoder_exn_of_deconstr (Deconstr.record tyname) ?trace
+    let object_exn   tyname ?trace     = decoder_exn_of_deconstr (Deconstr.object_ tyname) ?trace
       
   end
 
 
   module Constr : sig
     val tuple        : target list -> target
-    val variant      : string -> target list -> target
-    val poly_variant : string -> target list -> target
-    val record       : (string * target) list -> target
-    val object_      : (string * target) list -> target
+    val variant      : string -> string -> target list -> target
+    val poly_variant : string -> string -> target list -> target
+    val record       : string -> (string * target) list -> target
+    val object_      : string -> (string * target) list -> target
   end
   
   module Deconstr : sig
     (** Primitive ADT decoders. They may raise exceptions. *)
 
     val tuple        : target -> target list
-    val variant      : target -> string * target list
-    val poly_variant : target -> string * target list
-    val record       : target -> (string * target) list
-    val object_      : target -> (string * target) list
+    val variant      : string -> target -> string * target list
+    val poly_variant : string -> target -> string * target list
+    val record       : string -> target -> (string * target) list
+    val object_      : string -> target -> (string * target) list
   end
 end
 
   (** Auto generated decoders from Deconstr *)
   module DeconstrDecoder : sig
     val tuple        : target list              decoder
-    val variant      : (string * target list)   decoder
-    val poly_variant : (string * target list)   decoder
-    val record       : ((string * target) list) decoder
-    val object_      : ((string * target) list) decoder
+    val variant      : string -> (string * target list)   decoder
+    val poly_variant : string -> (string * target list)   decoder
+    val record       : string -> ((string * target) list) decoder
+    val object_      : string -> ((string * target) list) decoder
 
     val tuple_exn        : target list              decoder_exn
-    val variant_exn      : (string * target list)   decoder_exn
-    val poly_variant_exn : (string * target list)   decoder_exn
-    val record_exn       : ((string * target) list) decoder_exn
-    val object_exn       : ((string * target) list) decoder_exn
+    val variant_exn      : string -> (string * target list)   decoder_exn
+    val poly_variant_exn : string -> (string * target list)   decoder_exn
+    val record_exn       : string -> ((string * target) list) decoder_exn
+    val object_exn       : string -> ((string * target) list) decoder_exn
   end
 
   val exn : 'a decoder -> 'a decoder_exn
 
   module Constr = 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
+    let variant _tyname tag ts = Variant (tag, ts)
+    let poly_variant _tyname tag ts = Poly_variant (tag, ts)
+    let record _tyname fields = Record fields
+    let object_ _tyname fields = Object fields
   end
 
   module Deconstr = struct
 
     (* Variants and poly variants, and records and objects 
        are compatible each other, resp.ly. *)
-    let variant = function 
+    let variant _tyname = function 
       | Variant (tag, ts) -> tag, ts
       | Poly_variant (tag, ts) -> tag, ts
       | _ -> failwith "Variant expected for variant"
 
-    let poly_variant = function 
+    let poly_variant _tyname = function 
       | Variant (tag, ts) -> tag, ts
       | Poly_variant (tag, ts) -> tag, ts
       | _ -> failwith "Poly_variant expected for poly_variant"
 
-    let record = function
+    let record _tyname = function
       | Record alist -> alist
       | Object alist -> alist
       | _ -> failwith "Record expected for record"
 
-    let object_ = function 
+    let object_ _tyname = function 
       | Record alist -> alist
       | Object alist -> alist
       | _ -> failwith "Object expected for object"
 
 let failwithf fmt = Printf.ksprintf failwith fmt
 
+(* string anti quote does not escape DOUBLEQUOTE in OCaml 4.00.1.
+   I do not know it is fixed in 4.01 but 
+   
+   let s = "hello \"world\"" in
+   <:expr< $str:s$ >>  ==  Camlp4OCamlPrinter ==>  "hello "world""
+
+   In our case, DOUBLEQUOTE is not very important so we just drop them.
+ *)
+
+let string_anti_quote_fix s =
+  let b = Buffer.create (String.length s) in
+  for i = 0 to String.length s - 1 do
+    match s.[i] with   
+    | '"' -> ()
+    | c -> Buffer.add_char b c
+  done;
+  Buffer.contents b
+
 (* syntax modification **************************************************)
 
 open Syntax
     (* CR jfuruse: dupe with decoder *)
     let tyd_loc, name = match top with
       | Some top -> top
-      | None -> Loc.ghost, Printf.sprintf "poly-variant at %s" (Loc.to_string _loc) 
+      | None -> 
+          (* type t = [ `A ... ] *)
+          Loc.ghost, 
+          string_anti_quote_fix (Printf.sprintf "poly-variant at %s" (Loc.to_string _loc)) 
     in
     let annot = interprete_variant_type_name_annotation tyd_loc name in 
     if not annot.one_of then 
         let ids = mk_idents "__x" (List.length ctyps) in
         let patt = create_patt_app (patt_of_idstr loc idstr) (List.map patt_of_id ids) in
         let exp = create_expr_app encf
-          [ <:expr< $str: id_name$ >>;
+          [ <:expr< __tyname >>;
+            <: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)$ >>
+      <:expr< 
+        let __tyname = $str:name$ in
+        function $mcOr_of_list (List.map case cases)$ 
+      >>
 
     else
       
     (* CR jfuruse: dupe with decoder *)
     let tyd_loc, name = match top with
       | Some top -> top
-      | None -> Loc.ghost, Printf.sprintf "poly-variant at %s" (Loc.to_string _loc) 
+      | None -> 
+          (* type t = < ... > *)
+          Loc.ghost, 
+          string_anti_quote_fix (Printf.sprintf "object at %s" (Loc.to_string _loc))
     in
     let _annot = interprete_record_type_name_annotation tyd_loc name in 
     let decode_exn = match kind with
 
       | { embeded = Some (`Embeded, ctyp); _ } -> 
           let f = gen_ctyp (strip_field_flags ctyp) in
-          <:expr< $decode_exn$ 
+          <:expr< $decode_exn$ $str:name$
                       ~trace: [`Field $str:name_of_ident lab_id$; `Field $str:name$] 
                      ($f$ $accessor lab_id$) 
           >> :: fields
           <:expr< match $accessor lab_id$ with
                   | None -> []
                   | Some v -> 
-                      $decode_exn$ 
+                      $decode_exn$ $str:name$
                         ~trace: [`Field $str:name_of_ident lab_id$; `Field $str:name$] 
                         ($f$ v)
           >> :: fields
 
     in
     let exp = <:expr< List.flatten $create_list fields$ >> in
-    <:expr< (fun __v -> $creator$ $exp$) >>
+    <:expr< 
+      fun __v -> $creator$ $str:name$ $exp$
+    >>
 
   and gen_object ?top _loc field_types =
     let accessor lab_id = <:expr< __v#$name_of_ident lab_id$ >> in
   and gen_gen_variants kind constructor_of_idstr ?top _loc cases = 
     let tyd_loc, name = match top with
       | Some top -> top
-      | None -> Loc.ghost, Printf.sprintf "poly-variant at %s" (Loc.to_string _loc) 
+      | None -> 
+          (* type t = [ `A ... ] *)
+          Loc.ghost, 
+          string_anti_quote_fix (Printf.sprintf "poly-variant at %s" (Loc.to_string _loc)) 
     in
     let annot = interprete_variant_type_name_annotation tyd_loc name in 
 
       in
       <:expr< fun ?trace:(__t=[]) __v -> 
         let __name = $str:name$ in
-        match $decode$ ~trace:__t __v with 
+        match $decode$ __name ~trace:__t __v with 
         | `Ok v -> (match v with $mcOr_of_list cases$)
         | `Error e -> `Error e
       >>
   and gen_gen_record kind creator ?top _loc field_types = 
     let tyd_loc, name = match top with
       | Some top -> top
-      | None -> Loc.ghost, Printf.sprintf "object at %s" (Loc.to_string _loc) 
+      | None -> 
+          (* type t = < ... > *)
+          Loc.ghost, 
+          string_anti_quote_fix (Printf.sprintf "object at %s" (Loc.to_string _loc)) 
     in
     let annot = interprete_record_type_name_annotation tyd_loc name in
 
                  - inefficient
                  - record or object is fixed by the parent type, not by itself
               *)
-              let v = $encoder$ secondary_fields in
+              let v = $encoder$ "_dummy_type_name_" secondary_fields in
               match 
                 Meta_conv.Internal.embeded_decoding_helper secondary_fields v
                   ($gen_ctyp ctyp$ ~trace:(`Field $str:name_of_ident lab_id$ :: __t) v) 
                  - inefficient
                  - record or object is fixed by the parent type, not by itself
               *)
-              let v = $encoder$ secondary_fields in
+              let v = $encoder$ "_dummy_type_name_" secondary_fields in
               match 
                 Meta_conv.Internal.embeded_decoding_helper secondary_fields v
                   ($gen_ctyp ctyp$ ~trace:(`Field $str:name_of_ident lab_id$ :: __t) v) 
     <:expr< fun ?trace:(__t=[]) __v -> 
       let __name = $str:name$ in
       let primary_labels = $primary_labels$ in
-      match $decode$ ~trace:__t __v with
+      match $decode$ __name ~trace:__t __v with
       | `Error e -> `Error e
       | `Ok fields ->
           let primary_fields, secondary_fields = Meta_conv.Internal.filter_fields primary_labels fields in