From: Prashanth Mundkur Date: Mon, 6 Apr 2009 21:06:17 +0000 (-0700) Subject: fix record handling, and other minor fixes X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=5e14fafa4ceb1c43c53d903e3d3cae461115aaf7;p=xenclient%2Ftoolstack.git fix record handling, and other minor fixes --- diff --git a/libs/json/codegen.ml b/libs/json/codegen.ml index 96d87a3..26a3dc6 100644 --- a/libs/json/codegen.ml +++ b/libs/json/codegen.ml @@ -90,12 +90,6 @@ module Var_env : VAR_ENV = struct (List.rev vlist), env end -module type TO = functor (Var_env: VAR_ENV) -> sig - val to_json: formatter -> Var_env.t -> var -> complex_type - val let_bind: formatter -> Var_env.t -> (* out *) var -> (* in *) var -> (* in_type *) complex_type -> unit - val def: formatter -> Var_env.t -> (* top_level_name *) string -> complex_type -> unit -end - module To = struct let prod_vars_to_str vlist = let elems = List.map name_of_var vlist in @@ -106,8 +100,8 @@ module To = struct "[| " ^ constr ^ (String.concat "; " elems) ^ " |]" let to_object_str fn_list fv_list = let elems = List.map2 (fun f v -> - Printf.sprintf "(%s, %s)" f (name_of_var v) - ) fn_list fv_list in + Printf.sprintf "(\"%s\", %s)" f (name_of_var v) + ) fn_list fv_list in "[| " ^ (String.concat "; " elems) ^ " |]" let to_record_str fnlist fvlist = let fields = List.map2 (fun fn fv -> @@ -123,9 +117,9 @@ module To = struct let optv, venv' = Var_env.new_ident_from_type venv optt in fprintf ff "(match %s with@," v; fprintf ff "| None -> Json_null@,"; - fprintf ff "@[@[| Some %s -> (@\n" (name_of_var optv); + fprintf ff "@[| Some %s ->@," (name_of_var optv); to_json ff venv' optv optt; - fprintf ff "@])@,)@]" + fprintf ff "@]@,)" | C_list elemt -> 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 @@ -137,32 +131,33 @@ module To = struct 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 - let arrayvn = name_of_var arrayv in - fprintf ff "@[@[let %s = Array.map (fun %s ->@," arrayvn (name_of_var elemv); + let jarrayv, venv' = Var_env.new_ident_from_name venv' v ~suffix:"_jarray" in + let jarrayvn = name_of_var jarrayv in + fprintf ff "@[let %s = Array.map@," jarrayvn; + fprintf ff "@[(fun %s ->@," (name_of_var elemv); to_json ff venv' elemv elemt; - fprintf ff "@,) %s in@]@," v; - fprintf ff "Json_array %s@]" arrayvn + fprintf ff "@]@,) %s in@]@," v; + fprintf ff "Json_array %s" jarrayvn | C_tuple ctlist -> let cvlist, venv' = Var_env.new_idents_from_types venv ctlist in let letvlist, venv' = Var_env.new_idents_from_vars venv' ~prefix:"j_" cvlist in let cvtlist = List.combine cvlist ctlist in fprintf ff "(match %s with@," v; - fprintf ff "@[@[| %s ->@," (prod_vars_to_str cvlist); + fprintf ff "@[| %s ->@," (prod_vars_to_str cvlist); List.iter2 (fun letv (cv, ct) -> let_bind ff venv' letv cv ct ) letvlist cvtlist; - fprintf ff "Json_array %s@]@,)@]" (to_array_str letvlist) + fprintf ff "Json_array %s@]@,)" (to_array_str letvlist) | C_record cls -> let fnlist, ftlist = List.split cls in let fvlist, venv' = Var_env.new_idents_from_types venv ftlist in let letvlist, venv' = Var_env.new_idents_from_vars venv' ~prefix:"j_" fvlist in - fprintf ff "match %s with@," v; - fprintf ff "@[@[| %s ->@," (to_record_str fnlist fvlist); + fprintf ff "(match %s with@," v; + fprintf ff "@[| %s ->@," (to_record_str fnlist fvlist); List.iter2 (fun letv (fv, ft) -> let_bind ff venv' letv fv ft ) letvlist (List.combine fvlist ftlist); - fprintf ff "Json_array %s@]@,@]" (to_object_str fnlist letvlist) + fprintf ff "Json_object %s@]@,)" (to_object_str fnlist letvlist) | C_variant cdlist -> fprintf ff "(match %s with@," v; List.iter (fun cd -> variant ff venv cd) cdlist; @@ -179,9 +174,9 @@ module To = struct ) letvlist (List.combine vlist vtlist); fprintf ff "Json_array %s@]@," (to_array_str ~constr:vname letvlist) and let_bind ff venv letv inv typ = - fprintf ff "@[@[let %s =@," (name_of_var letv); + fprintf ff "@[let %s =@," (name_of_var letv); to_json ff venv inv typ; - fprintf ff " in@]@,@]" + fprintf ff " in@]@," 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 @@ -194,7 +189,7 @@ let generate_to_def ff is_and (tname, trep) = let fn = tname ^ "_to_json" in To.def ff Var_env.new_env fn trep is_and -let generate_from_def ff (tname, trep) = +let generate_from_def ff is_and (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 *) @@ -203,13 +198,19 @@ 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) + fprintf ff "open %s@\n" (String.capitalize md); + fprintf ff "@\n" + +let generate_one_defn ff td = + match td with + | [] -> () + | h :: t -> + generate_to_def ff false h; + List.iter (generate_to_def ff true) t; + generate_from_def ff false h; + List.iter (generate_from_def ff true) t let generate defn_list ofn ifn = - let generate_one_defn ff td = - 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/parser.mly b/libs/json/parser.mly index c9eb750..534d527 100644 --- a/libs/json/parser.mly +++ b/libs/json/parser.mly @@ -126,8 +126,8 @@ record: field_decls: | field_decls SEMI field_decl { $3 :: $1 } -| /* epsilon */ - { [] } +| field_decl + { [ $1 ] } field_decl: | LIDENT COLON expr