implement the record trimming pragma

diff --git a/gen/json_conv/codegen.ml b/gen/json_conv/codegen.ml
index 4b70e2fe3ebc2011ce8b81f2fe73ba28a2011d7e..cbb0ab9d7bbc711278d3af61de228961bafb89e9 100644 (file)
--- a/gen/json_conv/codegen.ml
+++ b/gen/json_conv/codegen.ml
@@ -91,6 +91,12 @@ module Var_env = struct
                (List.rev vlist), env
 end
 
+let verbose = ref false
+
+let dbg =
+  let logger s = if !verbose then Printf.printf "%s" s in
+  Printf.ksprintf logger
+
 module Pragma = struct
        exception Missing_prefix of string * string
 
@@ -126,22 +132,19 @@ module Pragma = struct
        let record_prefix = ref ""
        let process_pragma p =
                let p = clist_to_str (trim p) in
-               (* Printf.printf "Saw pragma %s\n" p; *)
+               dbg "Saw pragma %s.\n" p;
                if is_prefix "set_record_prefix=" p then begin
                        record_prefix := strip_prefix "set_record_prefix=" p;
-                       (* Printf.printf "Set record prefix to \"%s\"\n" !record_prefix *)
+                       dbg "Set record prefix to \"%s\".\n" !record_prefix
                end else if is_prefix "clear_record_prefix" p then begin
-                       record_prefix := "";
-                       (* Printf.printf "Cleared record prefix\n" *)
+                       dbg "Cleared record prefix (was \"%s\").\n" !record_prefix;
+                       record_prefix := ""
                end
 
-       let cook_To_field_name fn =
+       let json_field_name fn =
                if is_prefix !record_prefix fn
                then strip_prefix !record_prefix fn
                else raise (Missing_prefix (!record_prefix, fn))
-
-       let cook_Of_field_name fn =
-               !record_prefix ^ fn
 end
 
 type rec_type = First | Next
@@ -156,8 +159,9 @@ module To = struct
                let constr = if constr = "" then "" else "(Json_conv.string_to_json \"" ^ constr ^ "\"); " in
                "[| " ^ constr ^ (String.concat "; " elems) ^ " |]"
 
-       let to_object_str fn_list fv_list =
+       let to_object_str ?(is_record=false) fn_list fv_list =
                let elems = List.map2 (fun f v ->
+                                       let f = if is_record then Pragma.json_field_name f else f in
                                        Printf.sprintf "(\"%s\", %s)" f (name_of_var v)
                                      ) fn_list fv_list in
                "[| " ^ (String.concat "; " elems) ^ " |]"
@@ -220,7 +224,7 @@ module To = struct
                        List.iter2 (fun letv (fv, ft) ->
                                        let_bind ff venv letv fv ft
                                   ) letvlist (List.combine fvlist ftlist);
-                       fprintf ff "Json.Object %s@]@,)" (to_object_str fnlist letvlist)
+                       fprintf ff "Json.Object %s@]@,)" (to_object_str ~is_record:true fnlist letvlist)
                | C_variant cdlist ->
                        fprintf ff "(match %s with@," v;
                        List.iter (fun cd -> variant ff venv cd) cdlist;
@@ -322,7 +326,7 @@ module From = struct
                        List.iter2 (fun letv (fn, ft) ->
                                        let fvar, venv = Var_env.new_ident_from_name venv ~suffix:"_f" fn in
                                        let optional = match ft with C_option _ -> "optional_" | _ -> "" in
-                                       fprintf ff "let %s = Json_conv.get_%sobject_field %s \"%s\" in@," (name_of_var fvar) optional objtvn fn;
+                                       fprintf ff "let %s = Json_conv.get_%sobject_field %s \"%s\" in@," (name_of_var fvar) optional objtvn (Pragma.json_field_name fn);
                                        let_bind ff venv letv fvar ft tname
                                   ) letvlist cls;
                        fprintf ff "%s" (to_record_str fnlist letvlist)

diff --git a/gen/json_conv/gen_json_conv.ml b/gen/json_conv/gen_json_conv.ml
index dfb83cd193d3df188c9a3cef7a6836413244ae91..c3278dc90747c09edbebdd5ad9ad8f5c2fe934db 100644 (file)
--- a/gen/json_conv/gen_json_conv.ml
+++ b/gen/json_conv/gen_json_conv.ml
@@ -64,8 +64,9 @@ let () =
 
        (* parse argv *)
        let larg = [
-               ("-i", Arg.Set_string input, "input file");
-               ("-o", Arg.Set_string output, "output file");
+               ("-i", Arg.Set_string input, " input file");
+               ("-o", Arg.Set_string output, " output file");
+               ("-d", Arg.Set Codegen.verbose, " debug codegen logging");
        ] in
        let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
        Arg.parse larg (fun s -> ()) usage_msg;