From 5fbf565bfe34dfce44390bcaa7787eca6856713c Mon Sep 17 00:00:00 2001 From: Prashanth Mundkur Date: Mon, 6 Apr 2009 11:43:15 -0700 Subject: [PATCH] first cut at codegen of _to_json --- libs/json/codegen.ml | 178 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 153 insertions(+), 25 deletions(-) diff --git a/libs/json/codegen.ml b/libs/json/codegen.ml index 697f44c..11e9b94 100644 --- a/libs/json/codegen.ml +++ b/libs/json/codegen.ml @@ -16,15 +16,13 @@ open Syntax open Format -type var = -{ - stem: string; - mark: int -} +let base_to_str = function + | B_string -> "string" | B_int -> "int" | B_int64 -> "int64" + | B_bool -> "bool" | B_ident s -> s -type cg_state +type var = { stem: string; mark: int } -let ident_of_var v = +let name_of_var v = match v.mark with | 0 -> Printf.sprintf "%s" v.stem | d -> Printf.sprintf "%s_%d" v.stem d @@ -32,36 +30,166 @@ let ident_of_var v = module type VAR_ENV = sig type t val new_env: t - val new_ident_from_string: string -> var * t - val new_ident_from_type: complex_type -> var * t + val new_ident_from_name: t -> ?prefix:string -> ?suffix:string -> string -> var * t + val new_ident_from_type: t -> complex_type -> var * t + val new_idents_from_types: t -> complex_type list -> var list * t + val new_idents_from_vars: t -> ?prefix:string -> ?suffix:string -> var list -> var list * t end -module type TYPE_ENV = sig - type 'a t - val new_env: 'a t - val record: 'a t -> var -> 'a -> 'a t - val lookup: 'a t -> var -> 'a +module Var_env : VAR_ENV = struct + module StringMap = Map.Make (struct type t = string let compare = compare end) + + type name_entry = { cur_mark: int; entries: var list; } + + 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 } + + type t = name_entry StringMap.t + let new_env = StringMap.empty + + let new_var env full_name = + let var, new_entry = make_new_var (try StringMap.find full_name env + with Not_found -> new_name_entry) full_name in + var, (StringMap.add full_name new_entry env) + + let new_ident_from_name env ?(prefix="") ?(suffix="") stem = + new_var env (prefix ^ stem ^ suffix) + + let base_to_stem = function + | B_string -> "str" | B_int -> "int" | B_int64 -> "int64" + | B_bool -> "bool" | B_ident s -> s + + let complex_type_to_stem = function + | C_base b -> base_to_stem b | C_option _ -> "opt" | C_list _ -> "lst" + | C_array _ -> "arr" | C_tuple _ -> "tup" | C_record _ -> "rec" + | C_variant _ -> "var" + + let new_ident_from_type env ct = + 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 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 +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 type TO = sig - val disp_array: formatter -> var list -> formatter - val disp_object: formatter -> (string * var) list -> formatter - val let_binding: cg_state -> formatter - -> (* out *) var -> (* in *) var -> complex_type - -> formatter +module To = struct + let prod_vars_to_str vlist = + let elems = List.map name_of_var vlist in + 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 + "[| " ^ 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 + "[| " ^ (String.concat "; " elems) ^ " |]" + let to_record_str fnlist fvlist = + let fields = List.map2 (fun fn fv -> + Printf.sprintf "%s = %s" fn (name_of_var fv) + ) fnlist fvlist in + "{ " ^ (String.concat "; " fields) ^ " }" + let rec to_json ff venv inv typ = + let v = name_of_var inv in + match typ with + | C_base bt -> + fprintf ff "%s_to_json %s" (base_to_str bt) v + | C_option optt -> + 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); + to_json ff venv' optv optt; + 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 + let jlistvn = name_of_var jlistv in + fprintf ff "@[@[let %s = List.map (fun %s ->@," jlistvn (name_of_var elemv); + to_json ff venv' elemv elemt; + 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 + let arrayvn = name_of_var arrayv in + fprintf ff "@[@[let %s = Array.map (fun %s ->@," arrayvn (name_of_var elemv); + to_json ff venv' elemv elemt; + fprintf ff "@,) %s in@]@," v; + fprintf ff "Json_array %s@]" arrayvn + | 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); + List.iter2 (fun letv (cv, ct) -> + let_bind ff venv' letv cv ct + ) letvlist cvtlist; + 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); + 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) + | C_variant cdlist -> + fprintf ff "@[@[(match %s with@," v; + List.iter (fun cd -> variant ff venv cd) cdlist; + 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); + 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) + and let_bind ff venv letv inv typ = + fprintf ff "@[@[let %s =@," (name_of_var letv); + to_json ff venv inv typ; + fprintf ff " in@]@,@]" + let def ff venv fn_name typ = + 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 "@[@[let %s %s =@," fn_name (name_of_var inv); + to_json ff venv' inv typ; + fprintf ff "@]@,@,@]\n" end let generate_to_def ff (tname, trep) = let fn = tname ^ "_to_json" in - match trep with - | C_base _ -> - (* already present in lib; assumed generated for B_ident *) - () - | _ -> Printf.printf "Generating %s\n" fn + To.def ff Var_env.new_env fn trep 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 = -- 2.39.5