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
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 "@[<v 0>@[<v 8>| 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 "@[<v 0>@[<v 8>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 "@[<v 0>@[<v 8>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 "@[<v 0>@[<v 8>| %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 "@[<v 0>@[<v 8>| %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 "@[<v 0>@[<v 8>(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 "@[<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 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);
+ 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 =
projects / xenclient / toolstack.git / commitdiff