some fixes from testing

diff --git a/libs/json/codegen.ml b/libs/json/codegen.ml
index 11e9b947af5a60a5eddbfad93e784a198660e104..96d87a384d0643fa671556e49bb210ec6794865e 100644 (file)
--- a/libs/json/codegen.ml
+++ b/libs/json/codegen.ml
@@ -44,8 +44,8 @@ module Var_env : VAR_ENV = struct
        let new_name_entry = { cur_mark = 0; entries = [] }
 
        let make_new_var name_entry name =
-               let var = { stem = name; mark = name_entry.cur_mark + 1} in
-               var, { cur_mark = var.mark; entries = var :: name_entry.entries }
+               let var = { stem = name; mark = name_entry.cur_mark} in
+               var, { cur_mark = var.mark + 1; entries = var :: name_entry.entries }
 
        type t = name_entry StringMap.t
        let new_env = StringMap.empty
@@ -71,19 +71,23 @@ module Var_env : VAR_ENV = struct
                new_ident_from_name env (complex_type_to_stem ct)
 
        let new_idents_from_types env cts =
-               List.fold_left (fun (vlist, env) ct ->
-                                       let v, env' = new_ident_from_type env ct in
-                                       (v :: vlist), env'
-                              ) ([], env) cts
+               let vlist, env =
+                       List.fold_left (fun (vlist, env) ct ->
+                                               let v, env' = new_ident_from_type env ct in
+                                               (v :: vlist), env'
+                                      ) ([], env) cts in
+               (List.rev vlist), env
 
        let new_ident_from_var env ?(prefix="") ?(suffix="") var =
                new_ident_from_name env ~prefix ~suffix var.stem
 
        let new_idents_from_vars env ?(prefix="") ?(suffix="") vlist =
-               List.fold_left (fun (vlist, env) v ->
-                                       let v, env' = new_ident_from_var env ~prefix ~suffix v in
-                                       (v :: vlist), env'
-                              ) ([], env) vlist
+               let vlist, env =
+                       List.fold_left (fun (vlist, env) v ->
+                                               let v, env' = new_ident_from_var env ~prefix ~suffix v in
+                                               (v :: vlist), env'
+                                      ) ([], env) vlist in
+               (List.rev vlist), env
 end
 
 module type TO = functor (Var_env: VAR_ENV) -> sig
@@ -98,7 +102,7 @@ module To = struct
                String.concat ", " elems
        let to_array_str ?(constr="") vlist =
                let elems = List.map name_of_var vlist in
-               let constr = if constr = "" then "" else constr ^ "; " in
+               let constr = if constr = "" then "" else "(string_to_json \"" ^ constr ^ "\"); " in
                "[| " ^ constr ^ (String.concat "; " elems) ^ " |]"
        let to_object_str fn_list fv_list =
                let elems = List.map2 (fun f v ->
@@ -126,10 +130,11 @@ module To = struct
                        let elemv, venv' = Var_env.new_ident_from_type venv elemt in
                        let jlistv, venv' = Var_env.new_ident_from_name venv' v ~suffix:"_jlist" in
                        let jlistvn = name_of_var jlistv in
-                       fprintf ff "@[<v 0>@[<v 8>let %s = List.map (fun %s ->@," jlistvn (name_of_var elemv);
+                       fprintf ff "@[<v 8>let %s = List.map@," jlistvn;
+                       fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
                        to_json ff venv' elemv elemt;
-                       fprintf ff "@,) %s in@]@," v;
-                       fprintf ff "Json_array (Array.of_list %s)@]" jlistvn
+                       fprintf ff "@]@,) %s in@]@," v;
+                       fprintf ff "Json_array (Array.of_list %s)" jlistvn
                | C_array elemt ->
                        let elemv, venv' = Var_env.new_ident_from_type venv elemt in
                        let arrayv, venv' = Var_env.new_ident_from_name venv' v ~suffix:"_jarray" in
@@ -159,43 +164,52 @@ module To = struct
                                   ) letvlist (List.combine fvlist ftlist);
                        fprintf ff "Json_array %s@]@,@]" (to_object_str fnlist letvlist)
                | C_variant cdlist ->
-                       fprintf ff "@[<v 0>@[<v 8>(match %s with@," v;
+                       fprintf ff "(match %s with@," v;
                        List.iter (fun cd -> variant ff venv cd) cdlist;
-                       fprintf ff "@]@,)@]"
+                       fprintf ff ")"
        and variant ff venv (CD_tuple (vname, vtlist)) =
                let vlist, venv' = Var_env.new_idents_from_types venv vtlist in
                let letvlist, venv' = Var_env.new_idents_from_vars venv' ~prefix:"j_" vlist in
-               fprintf ff "| %s (%s) ->@," vname (prod_vars_to_str vlist);
+               if List.length vlist = 0 then
+                       fprintf ff "@[<v 8>| %s ->@," vname
+               else
+                       fprintf ff "@[<v 8>| %s (%s) ->@," vname (prod_vars_to_str vlist);
                List.iter2 (fun letv (v, vt) ->
                                let_bind ff venv' letv v vt
                           ) letvlist (List.combine vlist vtlist);
-               fprintf ff "Json_array %s" (to_array_str ~constr:vname letvlist)
+               fprintf ff "Json_array %s@]@," (to_array_str ~constr:vname letvlist)
        and let_bind ff venv letv inv typ =
                fprintf ff "@[<v 0>@[<v 8>let %s =@," (name_of_var letv);
                to_json ff venv inv typ;
                fprintf ff " in@]@,@]"
-       let def ff venv fn_name typ =
+       let def ff venv fn_name typ is_and =
                let fnv, venv' = Var_env.new_ident_from_name venv fn_name in
                let inv, venv' = Var_env.new_ident_from_name venv' "o" in
-               fprintf ff "@[<v 0>@[<v 8>let %s %s =@," fn_name (name_of_var inv);
+               fprintf ff "@[<v 8>%s %s %s =@," (if is_and then "and" else "let rec") fn_name (name_of_var inv);
                to_json ff venv' inv typ;
-               fprintf ff "@]@,@,@]\n"
+               fprintf ff "@]@,@\n"
 end
 
-let generate_to_def ff (tname, trep) =
+let generate_to_def ff is_and (tname, trep) =
        let fn = tname ^ "_to_json" in
-       To.def ff Var_env.new_env fn trep
+       To.def ff Var_env.new_env fn trep is_and
 
 let generate_from_def ff (tname, trep) =
        let fn = tname ^ "_from_json" in
        Printf.printf "Generating %s\n" fn
        (* From.def ff Var_env.new_env Type_env.new_env fn trep *)
 
-let generate defn_list f =
-       let generate_one ff td =
-               generate_to_def ff td;
-               generate_from_def ff td in
+let generate_header ff ifn =
+       let md = Filename.basename (Filename.chop_extension ifn) in
+       fprintf ff "open Json@\n";
+       fprintf ff "open Base_conv@\n";
+       fprintf ff "open %s@\n" (String.capitalize md)
+
+let generate defn_list ofn ifn =
        let generate_one_defn ff td =
-               List.iter (generate_one ff) td in
-       let ff = formatter_of_out_channel (open_out f) in
+               match td with
+               | [] -> ()
+               | h :: t -> generate_to_def ff false h; List.iter (generate_to_def ff true) t in
+       let ff = formatter_of_out_channel (open_out ofn) in
+       generate_header ff ifn;
        List.iter (generate_one_defn ff) defn_list

diff --git a/libs/json/jsonc.ml b/libs/json/jsonc.ml
index 266fd949b725ba96d759a5d2294511a73af208c9..f536e86ba68a58088eecdc23f931436989d6d76e 100644 (file)
--- a/libs/json/jsonc.ml
+++ b/libs/json/jsonc.ml
@@ -76,4 +76,4 @@ let () =
 
        match !input with
        | "" -> Printf.printf "%s\n" usage_msg
-       | file -> gen_code (parse_file file) !output
+       | file -> gen_code (parse_file file) !output !input