Add some useful pragmas to json-conv, doc them in README, and add to tests.

Also make parsing of existing ones more robust, and correctly handle module qualified variables, which were getting treated as value constructors.

diff --git a/gen/json_conv/codegen.ml b/gen/json_conv/codegen.ml
index d0020d78945990ac440afb5cf442041647b47adc..1a72758f3fcf90f7c3ed340e7ae16865eed20fcc 100644 (file)
--- a/gen/json_conv/codegen.ml
+++ b/gen/json_conv/codegen.ml
@@ -23,13 +23,22 @@ let is_known_type ident = List.mem ident !known_types
 let add_known_type ident = known_types := ident :: !known_types
 let reset_known_types () = known_types := []
 
+let converters = ((ref []) : (string * string) list ref)
+let add_converter ident conv =
+       add_known_type ident;
+       converters := (ident, conv) :: !converters
+let find_converter ident =
+       try List.assoc ident !converters
+       with Not_found -> ident
+let reset_converters () = converters := []
+
 let base_to_str = function
        | B_string -> "Json_conv.string"
        | B_int -> "Json_conv.int"
        | B_int64 -> "Json_conv.int64"
        | B_float -> "Json_conv.float"
        | B_bool -> "Json_conv.bool"
-       | B_ident s -> s
+       | B_ident s -> find_converter s
 
 type var = { stem: string; mark: int }
 
@@ -100,19 +109,54 @@ let dbg fmt =
 
 module Pragma = struct
        exception Missing_prefix of string * string
+       exception Unknown_pragma of string
 
-       let is_space c = c = ' ' || c = '\t' || c = '\n'
-
-       let rev_strip_leading clist =
-               let do_char (l, pass) c =
-                       if pass then c::l, true
-                       else if is_space c then l, false
-                       else c::l, true
-               in
-               fst (List.fold_left do_char ([], false) clist)
+       (* NOTE: To make parsing pragmas robust, use a space at each
+          end of the Scanf format string.
+       *)
 
-       let trim clist =
-               rev_strip_leading (rev_strip_leading clist)
+       let record_prefix = ref ""
+       let try_parse_set_record_prefix p =
+               try
+                       Scanf.sscanf p " set_record_prefix = %s "
+                               (fun prefix ->
+                                       record_prefix := prefix;
+                                       dbg "Set record prefix to \"%s\".\n" !record_prefix
+                               );
+                       true
+               with _ -> false
+
+       let try_parse_clear_record_prefix p =
+               try
+                       Scanf.sscanf p " %s "
+                               (fun p ->
+                                       if p = "clear_record_prefix" then begin
+                                               dbg "Cleared record prefix (was \"%s\").\n" !record_prefix;
+                                               record_prefix := "";
+                                               true
+                                       end else false
+                               )
+               with _ -> false
+
+       let try_parse_use_converter p =
+               try
+                       Scanf.sscanf p " use_converter %s for %s "
+                               (fun conv typ ->
+                                       dbg "added converter \"%s\" for \"%s\"\n." conv typ;
+                                       add_converter typ conv
+                               );
+                       true
+               with _ -> false
+
+       let try_parse_open ff p =
+               try
+                       Scanf.sscanf p " open %s "
+                               (fun m ->
+                                       dbg "inserted open for module \"%s\"\n." m;
+                                       fprintf ff "open %s@\n" m
+                               );
+                       true
+               with _ -> false
 
        let clist_to_str clist =
                let len = List.length clist in
@@ -120,6 +164,14 @@ module Pragma = struct
                ignore (List.fold_left (fun pos c -> s.[pos] <- c; (pos - 1)) (len-1) clist);
                s
 
+       let process_pragma ff p =
+               let p = clist_to_str p in
+               if try_parse_set_record_prefix p then ()
+               else if try_parse_clear_record_prefix p then ()
+               else if try_parse_use_converter p then ()
+               else if try_parse_open ff p then ()
+               else raise (Unknown_pragma p)
+
        let is_prefix prefix str =
                let plen, slen = String.length prefix, String.length str in
                (plen <= slen) && (String.sub str 0 plen = prefix)
@@ -130,18 +182,6 @@ module Pragma = struct
                then String.sub str plen (slen - plen)
                else str
 
-       let record_prefix = ref ""
-       let process_pragma p =
-               let p = clist_to_str (trim p) in
-               dbg "Saw pragma %s.\n" p;
-               if is_prefix "set_record_prefix=" p then begin
-                       record_prefix := strip_prefix "set_record_prefix=" p;
-                       dbg "Set record prefix to \"%s\".\n" !record_prefix
-               end else if is_prefix "clear_record_prefix" p then begin
-                       dbg "Cleared record prefix (was \"%s\").\n" !record_prefix;
-                       record_prefix := ""
-               end
-
        let json_field_name fn =
                if is_prefix !record_prefix fn
                then strip_prefix !record_prefix fn
@@ -403,11 +443,14 @@ let print_exception e =
                Printf.sprintf "Unknown base type \"%s\"" id
        | Pragma.Missing_prefix (p, f) ->
                Printf.sprintf "Prefix \"%s\" cannot be stripped from field \"%s\"" p f
+       | Pragma.Unknown_pragma p ->
+               Printf.sprintf "Unable to parse pragma \"%s\"" p
        | e ->
                Printf.sprintf "%s" (Printexc.to_string e)
 
 let generate defn_list ofn ifn =
        reset_known_types ();
+       reset_converters ();
        (try Unix.unlink ofn with _ -> ());
        let op_flags = [ Open_wronly ; Open_creat; Open_trunc; Open_text ] in
        let oc = open_out_gen op_flags 0o444 ofn in
@@ -416,7 +459,7 @@ let generate defn_list ofn ifn =
                generate_header ff ifn;
                List.iter (function
                           | Pragma p ->
-                               Pragma.process_pragma p
+                               Pragma.process_pragma ff p
                           | Type_defn def ->
                                generate_one_defn ff def
                          ) defn_list;

diff --git a/gen/json_conv/lexer.mll b/gen/json_conv/lexer.mll
index 9ac002ca57893abc0002680907cd916639a71f17..aa36cca8d96f6909a5c1aa2bb06b53d2862ac515 100644 (file)
--- a/gen/json_conv/lexer.mll
+++ b/gen/json_conv/lexer.mll
@@ -86,7 +86,7 @@ rule main = parse
 | ident
        { let str = lexeme lexbuf in
          match String.get str 0 with
-         | 'A' .. 'Z' -> UIDENT str
+         | 'A' .. 'Z' -> if String.contains str '.' then QIDENT str else UIDENT str
          | 'a' .. 'z' -> LIDENT str
          | _ ->          raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
        }

diff --git a/gen/json_conv/parser.mly b/gen/json_conv/parser.mly
index 8eed7ad89c5a7e89648a38abb95cf4927210ac31..8b8188cdf7727189462f3315da757a140f6f9878 100644 (file)
--- a/gen/json_conv/parser.mly
+++ b/gen/json_conv/parser.mly
@@ -30,7 +30,7 @@ let raise_syntax_error e pos =
 %token EQUAL STAR SEMI SEMISEMI COLON BAR
 %token EOF
 
-%token <string> UIDENT LIDENT
+%token <string> UIDENT LIDENT QIDENT
 %token <char list> PRAGMA
 
 %start defn_list
@@ -107,9 +107,7 @@ base:
                  | "bool"   -> B_bool
                  | s        -> B_ident s
                }
-/* TODO:
-| UIDENT       { raise_syntax_error (Invalid_ident $1) }
-*/
+| QIDENT        { B_ident $1 }
 
 record:
 | LBRACE field_decls opt_semi RBRACE   { $2 }

diff --git a/gen/json_conv/tests/test_json_conv.ml b/gen/json_conv/tests/test_json_conv.ml
index 33ba8b71a5261a240ab2d4a3d3506de82b7ddda7..e886b5c8468cee7ba56d17135868f2fa375b62df 100644 (file)
--- a/gen/json_conv/tests/test_json_conv.ml
+++ b/gen/json_conv/tests/test_json_conv.ml
@@ -90,6 +90,10 @@ let check_complex_type2 () =
                 ] in
        test_list complex_type2_to_json complex_type2_of_json cs
 
+let check_open_and_conv () =
+       let cs = [ 1L; -1L ] in
+       test_list t_to_json t_of_json cs
+
 let parse_args () =
        let options = [("-print-value", Arg.Set do_print, " print output")] in
        let usage = Printf.sprintf "Usage: %s [options]" Sys.argv.(0) in
@@ -101,5 +105,6 @@ let _ =
        check_simple_type ();
        check_record_type ();
        check_complex_type1 ();
-       check_complex_type2 ()
+       check_complex_type2 ();
+       check_open_and_conv ()
 

diff --git a/gen/json_conv/tests/test_types.ml b/gen/json_conv/tests/test_types.ml
index cc5f9b89711dc4879d14b4d6953b3f8e8742905e..19f8ecf0f347bc64efaba86cdd7dbc4b9ac40266 100644 (file)
--- a/gen/json_conv/tests/test_types.ml
+++ b/gen/json_conv/tests/test_types.ml
@@ -48,3 +48,9 @@ type complex_type2 =
        record: record_type;
        complex_type1: complex_type1;
 }
+
+
+(*** json-pragma: open Json_conv ***)
+(*** json-pragma: use_converter int64 for Int64.t ***)
+
+type t = Int64.t

diff --git a/libs/json/README b/libs/json/README
index 72291dd78996bb4f8c6a723c96013bfcd4557d2e..ea0ffd57a3cf7644e38bbeb78c448aa4bb2da671 100644 (file)
--- a/libs/json/README
+++ b/libs/json/README
@@ -80,6 +80,30 @@ variants:
 | Constr2 <type>                   ["Constr2", enc(<type>)]
 | Constr3 (<type1>,<type2>)        ["Constr3", enc(<type1>), enc(<type2>)]
 
+
+The input file can specify some pragmas to control the generated code.
+A pragma is specified in the form:
+
+(*** json-pragma:  pragma  ***)
+^^^^^^^^^^^^^^^^^^        ^^^^^
+Note that specified characters (including spaces) must appear exactly
+as shown.
+
+A "set_record_prefix=p" pragma allows a prefix p to be trimmed from all
+fields of an ocaml record type before generating the corresponding
+json object, and added back when converting back from json.  The
+code-generator reports an error if a record field doesn't possess the
+specified prefix.  A "clear_record_prefix" pragma unsets this pragma.
+
+A "use_converter prefix for type" pragma allows the
+specification of alternate converter functions
+prefix_{to_json,of_json} for a specified type, instead of the default
+type_{to_json,of_json}.
+
+A "open module" pragma inserts an "open module" into the generated
+code.
+
+
 JSON-RPC boilerplate generator:
 -------------------------------