open Json
-exception Json_conv_failure of string
+type conv_error =
+ | Unexpected_json_type of (* rcvd *) string * (* expected *) string
+ | Array_length of (* rcvd *) int * (* expected *) int
+ | Unknown_constructor of (* type *) string * (* constructor *) string
+ | Missing_object_field of string
+
+exception Json_conv_failure of conv_error
+
+let raise_unexpected_json_type typ exp =
+ raise (Json_conv_failure (Unexpected_json_type (typ, exp)))
+
+let raise_short_array len exp =
+ raise (Json_conv_failure (Array_length (len, exp)))
+
+let raise_unknown_constructor typ cons =
+ raise (Json_conv_failure (Unknown_constructor (typ, cons)))
+
+let raise_missing_object_field field =
+ raise (Json_conv_failure (Missing_object_field field))
let string_of_json ?(permissive=false) j =
let strict = function
- | Json_null _ -> raise (Json_conv_failure "null->string")
- | Json_bool _ -> raise (Json_conv_failure "bool->string")
- | Json_int _ -> raise (Json_conv_failure "int->string")
- | Json_float _ -> raise (Json_conv_failure "float->string")
+ | Json_null _ -> raise_unexpected_json_type "null" "string"
+ | Json_bool _ -> raise_unexpected_json_type "bool" "string"
+ | Json_int _ -> raise_unexpected_json_type "int" "string"
+ | Json_float _ -> raise_unexpected_json_type "float" "string"
| Json_string s -> s
- | Json_object _ -> raise (Json_conv_failure "object->string")
- | Json_array _ -> raise (Json_conv_failure "array->string") in
+ | Json_object _ -> raise_unexpected_json_type "object" "string"
+ | Json_array _ -> raise_unexpected_json_type "array" "string" in
let lenient = function
| Json_null _ -> ""
- | Json_bool _ -> raise (Json_conv_failure "bool->string")
- | Json_int _ -> raise (Json_conv_failure "int->string")
- | Json_float _ -> raise (Json_conv_failure "float->string")
+ | Json_bool _ -> raise_unexpected_json_type "bool" "string"
+ | Json_int _ -> raise_unexpected_json_type "int" "string"
+ | Json_float _ -> raise_unexpected_json_type "float" "string"
| Json_string s -> s
- | Json_object _ -> raise (Json_conv_failure "object->string")
+ | Json_object _ -> raise_unexpected_json_type "object" "string"
| Json_array a ->
if Array.length a = 0 then
- raise (Json_conv_failure "array->string")
+ raise_unexpected_json_type "array" "string"
else
strict a.(0) in
if not permissive then strict j else lenient j
let int_of_json ?(permissive=false) j =
let strict = function
- | Json_null _ -> raise (Json_conv_failure "null->int")
- | Json_bool _ -> raise (Json_conv_failure "bool->int")
+ | Json_null _ -> raise_unexpected_json_type "null" "int"
+ | Json_bool _ -> raise_unexpected_json_type "bool" "int"
| Json_int i -> Int64.to_int i
- | Json_float _ -> raise (Json_conv_failure "float->int")
- | Json_string _ -> raise (Json_conv_failure "float->int")
- | Json_object _ -> raise (Json_conv_failure "object->int")
- | Json_array _ -> raise (Json_conv_failure "array->int") in
+ | Json_float _ -> raise_unexpected_json_type "float" "int"
+ | Json_string _ -> raise_unexpected_json_type "float" "int"
+ | Json_object _ -> raise_unexpected_json_type "object" "int"
+ | Json_array _ -> raise_unexpected_json_type "array" "int" in
let lenient = function
| Json_null _ -> 0
| Json_bool b -> if b then 1 else 0
| Json_int i -> Int64.to_int i
- | Json_float _ -> raise (Json_conv_failure "float->int")
- | Json_string _ -> raise (Json_conv_failure "string->int")
- | Json_object _ -> raise (Json_conv_failure "object->int")
+ | Json_float _ -> raise_unexpected_json_type "float" "int"
+ | Json_string _ -> raise_unexpected_json_type "string" "int"
+ | Json_object _ -> raise_unexpected_json_type "object" "int"
| Json_array a ->
if Array.length a = 0 then
- raise (Json_conv_failure "array->int")
+ raise_unexpected_json_type "array" "int"
else
strict a.(0) in
if not permissive then strict j else lenient j
let int64_of_json ?(permissive=false) j =
let strict = function
- | Json_null _ -> raise (Json_conv_failure "null->int64")
- | Json_bool _ -> raise (Json_conv_failure "bool->int64")
+ | Json_null _ -> raise_unexpected_json_type "null" "int64"
+ | Json_bool _ -> raise_unexpected_json_type "bool" "int64"
| Json_int i -> i
- | Json_float _ -> raise (Json_conv_failure "float->int64")
- | Json_string _ -> raise (Json_conv_failure "float->int64")
- | Json_object _ -> raise (Json_conv_failure "object->int64")
- | Json_array _ -> raise (Json_conv_failure "array->int64") in
+ | Json_float _ -> raise_unexpected_json_type "float" "int64"
+ | Json_string _ -> raise_unexpected_json_type "float" "int64"
+ | Json_object _ -> raise_unexpected_json_type "object" "int64"
+ | Json_array _ -> raise_unexpected_json_type "array" "int64" in
let lenient = function
| Json_null _ -> 0L
| Json_bool b -> if b then 1L else 0L
| Json_int i -> i
- | Json_float _ -> raise (Json_conv_failure "float->int64")
- | Json_string _ -> raise (Json_conv_failure "string->int64")
- | Json_object _ -> raise (Json_conv_failure "object->int64")
+ | Json_float _ -> raise_unexpected_json_type "float" "int64"
+ | Json_string _ -> raise_unexpected_json_type "string" "int64"
+ | Json_object _ -> raise_unexpected_json_type "object" "int64"
| Json_array a ->
if Array.length a = 0 then
- raise (Json_conv_failure "array->int64")
+ raise_unexpected_json_type "array" "int64"
else
strict a.(0) in
if not permissive then strict j else lenient j
let bool_of_json ?(permissive=false) j =
let strict = function
- | Json_null _ -> raise (Json_conv_failure "null->bool")
+ | Json_null _ -> raise_unexpected_json_type "null" "bool"
| Json_bool b -> b
- | Json_int i -> raise (Json_conv_failure "int->bool")
- | Json_float _ -> raise (Json_conv_failure "float->bool")
- | Json_string _ -> raise (Json_conv_failure "float->bool")
- | Json_object _ -> raise (Json_conv_failure "object->bool")
- | Json_array _ -> raise (Json_conv_failure "array->bool") in
+ | Json_int i -> raise_unexpected_json_type "int" "bool"
+ | Json_float _ -> raise_unexpected_json_type "float" "bool"
+ | Json_string _ -> raise_unexpected_json_type "float" "bool"
+ | Json_object _ -> raise_unexpected_json_type "object" "bool"
+ | Json_array _ -> raise_unexpected_json_type "array" "bool" in
let lenient = function
| Json_null _ -> false
| Json_bool b -> b
| Json_int i -> i <> 0L
- | Json_float _ -> raise (Json_conv_failure "float->bool")
- | Json_string _ -> raise (Json_conv_failure "string->bool")
- | Json_object _ -> raise (Json_conv_failure "object->bool")
+ | Json_float _ -> raise_unexpected_json_type "float" "bool"
+ | Json_string _ -> raise_unexpected_json_type "string" "bool"
+ | Json_object _ -> raise_unexpected_json_type "object" "bool"
| Json_array a ->
if Array.length a = 0 then
- raise (Json_conv_failure "array->bool")
+ raise_unexpected_json_type "array" "bool"
else
strict a.(0) in
if not permissive then strict j else lenient j
let bool_to_json b = Json_bool b
+
+
+(* utilities *)
+
+let json_type_name = function
+| Json_null -> "null"
+| Json_bool _ -> "bool"
+| Json_int _ -> "int"
+| Json_float _ -> "float"
+| Json_string _ -> "string"
+| Json_object _ -> "object"
+| Json_array _ -> "array"
+
+let json_is_string = function
+| Json_string _ -> true
+| _ -> false
+
+let check_array_with_length arr minlen =
+ let alen = Array.length arr in
+ if alen < minlen then
+ raise_short_array minlen alen
+
+let get_variant_constructor j =
+ match j with
+ | Json_array (arr) ->
+ let alen = Array.length arr in
+ if alen < 1 then
+ raise_short_array alen 1
+ else if not (json_is_string arr.(0)) then
+ raise_unexpected_json_type (json_type_name j) "string"
+ else
+ (string_of_json arr.(0)), arr
+ | _ ->
+ raise_unexpected_json_type (json_type_name j) "array"
+
+let get_array j =
+ match j with
+ | Json_array arr -> arr
+ | _ -> raise_unexpected_json_type (json_type_name j) "array"
+
+let get_array_elem arr i =
+ check_array_with_length arr (i + 1);
+ arr.(i)
+
+let get_list j =
+ Array.to_list (get_array j)
+
+type object_table = (string * Json.t) list
+
+let get_object_table j =
+ match j with
+ | Json_object a -> Array.to_list a
+ | _ -> raise_unexpected_json_type (json_type_name j) "object"
+
+let get_object_field t f =
+ try
+ List.assoc f t
+ with Not_found -> raise_missing_object_field f
| 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
+ 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 8>| Some %s ->@," (name_of_var optv);
- to_json ff venv' optv optt;
+ 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 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 8>let %s = List.map@," jlistvn;
fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- to_json ff venv' elemv elemt;
+ 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 jarrayv, venv' = Var_env.new_ident_from_name venv' v ~suffix:"_jarray" in
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
let jarrayvn = name_of_var jarrayv in
fprintf ff "@[<v 8>let %s = Array.map@," jarrayvn;
fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
- to_json ff venv' elemv elemt;
+ to_json ff venv elemv elemt;
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 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 8>| %s ->@," (prod_vars_to_str cvlist);
List.iter2 (fun letv (cv, ct) ->
- let_bind ff venv' letv cv ct
- ) letvlist cvtlist;
+ 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
+ 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 8>| %s ->@," (to_record_str fnlist fvlist);
List.iter2 (fun letv (fv, ft) ->
- let_bind ff venv' letv fv ft
+ let_bind ff venv letv fv ft
) letvlist (List.combine fvlist ftlist);
fprintf ff "Json_object %s@]@,)" (to_object_str fnlist letvlist)
| C_variant cdlist ->
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
+ 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
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
+ 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 =
to_json ff venv inv typ;
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
+ 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 8>%s %s %s =@," (if is_and then "and" else "let rec") fn_name (name_of_var inv);
- to_json ff venv' inv typ;
+ to_json ff venv inv typ;
+ fprintf ff "@]@,@\n"
+end
+
+module From = struct
+ let to_tuple_str ?(constr="") vlist =
+ let elems = List.map name_of_var vlist in
+ if List.length elems > 0 then
+ Printf.sprintf "%s(%s)" constr (String.concat ", " elems)
+ else
+ Printf.sprintf "%s" constr
+ 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 of_json ff venv inv typ tname =
+ let v = name_of_var inv in
+ match typ with
+ | C_base bt ->
+ fprintf ff "%s_of_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 "| Json_null -> None@,";
+ fprintf ff "@<v 8>| %s ->@," (name_of_var optv);
+ of_json ff venv optv optt tname;
+ fprintf ff "@]@,)"
+ | C_list elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
+ let oarrayvn = name_of_var oarrayv in
+ fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ of_json ff venv elemv elemt tname;
+ fprintf ff "@]@,) (get_array %s) in@]@," v;
+ fprintf ff "Array.to_list %s" oarrayvn
+ | C_array elemt ->
+ let elemv, venv = Var_env.new_ident_from_type venv elemt in
+ let oarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_oarray" in
+ let oarrayvn = name_of_var oarrayv in
+ fprintf ff "@[<v 8>let %s = Array.map@," oarrayvn;
+ fprintf ff "@[<v 8>(fun %s ->@," (name_of_var elemv);
+ of_json ff venv elemv elemt tname;
+ fprintf ff "@]@,) (get_array %s) in@]@," v;
+ fprintf ff "%s" oarrayvn
+ | C_tuple ctlist ->
+ let jarrayv, venv = Var_env.new_ident_from_name venv v ~suffix:"_jarray" in
+ let jarrayvn = name_of_var jarrayv in
+ let letvlist, venv = Var_env.new_idents_from_types venv ctlist in
+ fprintf ff "let %s = get_array %s in@," jarrayvn v;
+ fprintf ff "check_array_with_length %s %d;@," jarrayvn (List.length ctlist);
+ ignore (List.fold_left (fun indx (letv, ct) ->
+ let inv, venv = Var_env.new_ident_from_name venv "tindx" in
+ fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) jarrayvn indx;
+ let_bind ff venv letv inv ct tname;
+ indx + 1
+ ) 0 (List.combine letvlist ctlist));
+ fprintf ff "%s" (to_tuple_str letvlist)
+ | C_record cls ->
+ let fnlist, ftlist = List.split cls in
+ let letvlist, venv = Var_env.new_idents_from_types venv ftlist in
+ let objtv, venv = Var_env.new_ident_from_name venv v ~suffix:"_ftable" in
+ let objtvn = name_of_var objtv in
+ fprintf ff "let %s = get_object_table %s in@," objtvn v;
+ List.iter2 (fun letv (fn, ft) ->
+ let fvar, venv = Var_env.new_ident_from_name venv ~suffix:"_f" fn in
+ fprintf ff "let %s = get_object_field %s \"%s\" in@," (name_of_var fvar) objtvn fn;
+ let_bind ff venv letv fvar ft tname
+ ) letvlist cls;
+ fprintf ff "%s" (to_record_str fnlist letvlist)
+ | C_variant cdlist ->
+ let consv, venv = Var_env.new_ident_from_name venv "cons" in
+ let consvn = name_of_var consv in
+ let argsv, venv = Var_env.new_ident_from_name venv "args" in
+ let defmatchv, venv = Var_env.new_ident_from_name venv "s" in
+ let defmatchvn = name_of_var defmatchv in
+ fprintf ff "let %s, %s = get_variant_constructor %s in@,"
+ consvn (name_of_var argsv) v;
+ fprintf ff "(match %s with@," consvn;
+ List.iter (fun cd -> variant ff venv argsv cd tname) cdlist;
+ (* need to write a default match case *)
+ fprintf ff "| %s -> raise_unknown_constructor \"%s\" %s@,)"
+ defmatchvn tname defmatchvn
+ and variant ff venv argsv (CD_tuple (vname, vtlist)) tname =
+ let argsvn = name_of_var argsv in
+ let vtlen = List.length vtlist in
+ let vlist, venv = Var_env.new_idents_from_types venv vtlist in
+ let letvlist, venv = Var_env.new_idents_from_vars venv ~prefix:"o_" vlist in
+ fprintf ff "@[<v 8>| \"%s\" ->@," vname;
+ if vtlen > 0 then
+ fprintf ff "check_array_with_length %s %d;@," argsvn (vtlen + 1);
+ ignore (List.fold_left (fun indx (letv, vt) ->
+ let inv, venv = Var_env.new_ident_from_name venv "aindx" in
+ fprintf ff "let %s = %s.(%d) in@," (name_of_var inv) argsvn indx;
+ let_bind ff venv letv inv vt tname;
+ indx + 1
+ ) 1 (List.combine letvlist vtlist));
+ fprintf ff "%s@]@," (to_tuple_str ~constr:vname letvlist)
+ and let_bind ff venv letv inv typ tname =
+ fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
+ of_json ff venv inv typ tname;
+ fprintf ff " in@]@,"
+ let def ff venv fn_name (tname, 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 "j" in
+ fprintf ff "@[<v 8>%s %s %s =@," (if is_and then "and" else "let rec") fn_name (name_of_var inv);
+ of_json ff venv inv typ tname;
fprintf ff "@]@,@\n"
end
To.def ff Var_env.new_env fn trep is_and
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 *)
+ let fn = tname ^ "_of_json" in
+ From.def ff Var_env.new_env fn (tname, trep) is_and
let generate_header ff ifn =
let md = Filename.basename (Filename.chop_extension ifn) in
projects / xenclient / toolstack.git / commitdiff