JSON_FILES[] =
json
json_parse
- base_conv
+ json_conv
LIB = json
JSON_LIB = $(OCamlLibrary $(LIB), $(JSON_FILES))
-section
- TEST_PARSER_PROG = test_parser
- OCAML_LIBS += json
- TEST_PARSER = $(OCamlProgram $(TEST_PARSER_PROG), test_parser $(JSON_FILES))
- export TEST_PARSER
-
-section
- GEN_FILES = parser.mli parser.ml lexer.ml
- OCamlGeneratedFiles($(GEN_FILES))
- OCAML_OTHER_LIBS[] += unix
- CONV_FILES[] =
- lexer
- parser
- syntax
- codegen
- jsonc
-
- JSON_CONV_PROG = jsonc
- JSON_CONV = $(OCamlProgram $(JSON_CONV_PROG), $(CONV_FILES))
- export JSON_CONV JSON_CONV_PROG
-
-
-.DEFAULT: $(JSON_LIB) $(TEST_PARSER) $(JSON_CONV)
+.DEFAULT: $(JSON_LIB)
clean:
rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
-.SUBDIRS: jsonc_tests
+.SUBDIRS: gen_json_conv parser_tests
--- /dev/null
+This directory contains an incremental JSON parser, and a JSON<->OCaml
+conversion function generator.
+
+JSON parser:
+------------
+
+The parser is incremental in the sense that it can take pieces of
+input strings at a time that do not comprise a complete json value.
+This is useful when the json value is produced piecemeal, for example,
+when it arrives over a network.
+
+After consuming each string, the parser returns either (a) a
+notification that it needs more input to complete parsing a value, or
+(b) a parsed json value (along with any remaining unconsumed part of
+the input), or (c) a parsing exception.
+
+
+JSON <-> OCaml conversion function generator:
+-------------------------------------------
+
+The generator (in gen_json_conv/) takes as input a file containing _only_ OCaml
+type definitions, and generates an output file containing functions to
+convert ocaml values of the specified types to and from json values.
+
+The input type definitions can only use a restriction of the Ocaml
+type language, specified below:
+
+ base_type := <string> | <int> | <Int64.t> | <bool>
+
+ type_expr := base_type
+ | type_expr 'option'
+ | '{' field ':' type_expr ';' field ':' type_expr ... }
+ | type_expr 'array'
+ | type_expr 'list'
+ | type_expr '*' type_expr
+ | constr_type_expr { '|' constr_type_expr }
+
+ constr_type_expr := constr_name
+ | constr_name 'of' type_expr { '*' type_expr }
+
+That is, only mono-morphic types constructed from the specified base
+types are allowed; function types, polymorphic types or polymorphic
+variants, classes and exceptions are not handled, and result in parse
+errors.
+
+The "None" value of an option type is mapped to the json "null" value.
+
+The generated functions are named <ocaml_type>_of_json and
+<ocaml_type>_to_json for each input type defined. *_of_json functions
+can fail with a conversion exception.
+
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Json
-
-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_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_unexpected_json_type "object" "string"
- | Json_array _ -> raise_unexpected_json_type "array" "string" in
- let lenient = function
- | Json_null _ -> ""
- | 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_unexpected_json_type "object" "string"
- | Json_array a ->
- if Array.length a = 0 then
- raise_unexpected_json_type "array" "string"
- else
- strict a.(0) in
- if not permissive then strict j else lenient j
-
-let string_to_json s = Json_string s
-
-
-let int_of_json ?(permissive=false) j =
- let strict = function
- | 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_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_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_unexpected_json_type "array" "int"
- else
- strict a.(0) in
- if not permissive then strict j else lenient j
-
-let int_to_json i = Json_int (Int64.of_int i)
-
-
-let int64_of_json ?(permissive=false) j =
- let strict = function
- | Json_null _ -> raise_unexpected_json_type "null" "int64"
- | Json_bool _ -> raise_unexpected_json_type "bool" "int64"
- | Json_int i -> i
- | 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_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_unexpected_json_type "array" "int64"
- else
- strict a.(0) in
- if not permissive then strict j else lenient j
-
-let int64_to_json i = Json_int i
-
-let bool_of_json ?(permissive=false) j =
- let strict = function
- | Json_null _ -> raise_unexpected_json_type "null" "bool"
- | Json_bool b -> b
- | 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_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_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
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-
-(* conversion errors *)
-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
-
-
-(* conversion routines for base types *)
-val string_of_json: ?permissive:bool -> Json.t -> string
-val string_to_json: string -> Json.t
-
-val int_of_json: ?permissive:bool -> Json.t -> int
-val int_to_json: int -> Json.t
-
-val int64_of_json: ?permissive:bool -> Json.t -> int64
-val int64_to_json: int64 -> Json.t
-
-val bool_of_json: ?permissive:bool -> Json.t -> bool
-val bool_to_json: bool -> Json.t
-
-(* utilities used by generated code *)
-val raise_unexpected_json_type: string -> string -> 'a
-val raise_short_array: int -> int -> 'a
-val raise_unknown_constructor: string -> string -> 'a
-val check_array_with_length: 'a array -> int -> unit
-val get_variant_constructor: Json.t -> string * Json.t array
-val get_array: Json.t -> Json.t array
-val get_array_elem: Json.t array -> int -> Json.t
-val get_list: Json.t -> Json.t list
-
-type object_table
-val get_object_table: Json.t -> object_table
-val get_object_field: object_table -> string -> Json.t
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Syntax
-open Format
-
-exception Unknown_base_type of string
-
-let known_types = ((ref []) : string list ref)
-let is_known_type ident = List.mem ident !known_types
-let add_known_type ident = known_types := ident :: !known_types
-let reset_known_types () = known_types := []
-
-let base_to_str = function
- | B_string -> "string" | B_int -> "int" | B_int64 -> "int64"
- | B_bool -> "bool" | B_ident s -> s
-
-type var = { stem: string; mark: int }
-
-let name_of_var v =
- match v.mark with
- | 0 -> Printf.sprintf "%s" v.stem
- | d -> Printf.sprintf "%s_%d" v.stem d
-
-module 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} in
- var, { cur_mark = var.mark + 1; 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 =
- 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 =
- 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
-
-type rec_type = First | Next
-
-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 "(string_to_json \"" ^ 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 ->
- (match bt with
- | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
- | _ -> ());
- 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 8>| Some %s ->@," (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 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
- | 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 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;
- 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 "@[<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 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_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;
- 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
- 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)
-
- and let_bind ff venv letv inv typ =
- fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
- to_json ff venv inv typ;
- fprintf ff " in@]@,"
-
- let def ff venv fn_name typ recd =
- 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 decl = match recd with First -> "let rec" | Next -> "and" in
- fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
- 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
- let len = List.length elems in
- (match len with
- | 0 -> Printf.sprintf "%s" constr
- | 1 -> Printf.sprintf "%s %s" constr (List.hd elems)
- | _ -> Printf.sprintf "%s (%s)" constr (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 of_json ff venv inv typ tname =
- let v = name_of_var inv in
- match typ with
- | C_base bt ->
- (match bt with
- | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
- | _ -> ());
- 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 -> @,Some (" (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) recd =
- 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
- let decl = match recd with First -> "let rec" | Next -> "and" in
- fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
- of_json ff venv inv typ tname;
- fprintf ff "@]@,@\n@?"
-end
-
-let generate_to_def ff is_and (tname, trep) =
- To.def ff Var_env.new_env (tname ^ "_to_json") trep is_and
-
-let generate_from_def ff is_and (tname, trep) =
- From.def ff Var_env.new_env (tname ^ "_of_json") (tname, trep) is_and
-
-let generate_header ff ifn =
- let md = Filename.basename (Filename.chop_extension ifn) in
- let call = String.concat " " (Array.to_list Sys.argv) in
- fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call;
- fprintf ff "open Json@\n";
- fprintf ff "open Base_conv@\n";
- fprintf ff "open %s@\n@\n" (String.capitalize md)
-
-let generate_one_defn ff td =
- match td with
- | [] -> ()
- | h :: t ->
- List.iter (fun (tname, _) -> add_known_type tname) td;
- generate_to_def ff First h;
- List.iter (generate_to_def ff Next) t;
- generate_from_def ff First h;
- List.iter (generate_from_def ff Next) t
-
-let generate defn_list ofn ifn =
- reset_known_types ();
- let oc = open_out ofn in
- let ff = formatter_of_out_channel oc in
- try
- generate_header ff ifn;
- List.iter (generate_one_defn ff) defn_list;
- close_out oc
- with Unknown_base_type id ->
- Printf.eprintf "Error: Unknown base type \"%s\"\n" id;
- close_out oc;
- Unix.unlink ofn
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Syntax
+open Format
+
+exception Unknown_base_type of string
+
+let known_types = ((ref []) : string list ref)
+let is_known_type ident = List.mem ident !known_types
+let add_known_type ident = known_types := ident :: !known_types
+let reset_known_types () = known_types := []
+
+let base_to_str = function
+ | B_string -> "string" | B_int -> "int" | B_int64 -> "int64"
+ | B_bool -> "bool" | B_ident s -> s
+
+type var = { stem: string; mark: int }
+
+let name_of_var v =
+ match v.mark with
+ | 0 -> Printf.sprintf "%s" v.stem
+ | d -> Printf.sprintf "%s_%d" v.stem d
+
+module 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} in
+ var, { cur_mark = var.mark + 1; 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 =
+ 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 =
+ 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
+
+type rec_type = First | Next
+
+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 "(string_to_json \"" ^ 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 ->
+ (match bt with
+ | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
+ | _ -> ());
+ 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 8>| Some %s ->@," (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 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
+ | 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 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;
+ 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 "@[<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 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_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;
+ 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
+ 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)
+
+ and let_bind ff venv letv inv typ =
+ fprintf ff "@[<v 8>let %s =@," (name_of_var letv);
+ to_json ff venv inv typ;
+ fprintf ff " in@]@,"
+
+ let def ff venv fn_name typ recd =
+ 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 decl = match recd with First -> "let rec" | Next -> "and" in
+ fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
+ 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
+ let len = List.length elems in
+ (match len with
+ | 0 -> Printf.sprintf "%s" constr
+ | 1 -> Printf.sprintf "%s %s" constr (List.hd elems)
+ | _ -> Printf.sprintf "%s (%s)" constr (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 of_json ff venv inv typ tname =
+ let v = name_of_var inv in
+ match typ with
+ | C_base bt ->
+ (match bt with
+ | B_ident ident -> if not (is_known_type ident) then raise (Unknown_base_type ident)
+ | _ -> ());
+ 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 -> @,Some (" (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) recd =
+ 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
+ let decl = match recd with First -> "let rec" | Next -> "and" in
+ fprintf ff "@[<v 8>%s %s %s =@," decl fn_name (name_of_var inv);
+ of_json ff venv inv typ tname;
+ fprintf ff "@]@,@\n@?"
+end
+
+let generate_to_def ff is_and (tname, trep) =
+ To.def ff Var_env.new_env (tname ^ "_to_json") trep is_and
+
+let generate_from_def ff is_and (tname, trep) =
+ From.def ff Var_env.new_env (tname ^ "_of_json") (tname, trep) is_and
+
+let generate_header ff ifn =
+ let md = Filename.basename (Filename.chop_extension ifn) in
+ let call = String.concat " " (Array.to_list Sys.argv) in
+ fprintf ff "(* This file has been auto-generated using \"%s\". *)@\n@\n" call;
+ fprintf ff "open Json@\n";
+ fprintf ff "open Json_conv@\n";
+ fprintf ff "open %s@\n@\n" (String.capitalize md)
+
+let generate_one_defn ff td =
+ match td with
+ | [] -> ()
+ | h :: t ->
+ List.iter (fun (tname, _) -> add_known_type tname) td;
+ generate_to_def ff First h;
+ List.iter (generate_to_def ff Next) t;
+ generate_from_def ff First h;
+ List.iter (generate_from_def ff Next) t
+
+let generate defn_list ofn ifn =
+ reset_known_types ();
+ let oc = open_out ofn in
+ let ff = formatter_of_out_channel oc in
+ try
+ generate_header ff ifn;
+ List.iter (generate_one_defn ff) defn_list;
+ close_out oc
+ with Unknown_base_type id ->
+ Printf.eprintf "Error: Unknown base type \"%s\"\n" id;
+ close_out oc;
+ Unix.unlink ofn
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Syntax
+open Parser
+open Lexing
+
+let show_syntax_error e l =
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ l.pos_fname l.pos_lnum (l.pos_cnum - l.pos_bol) in
+ let msg =
+ match e with
+ | Illegal_character c -> Printf.sprintf "Illegal character %c" c
+ | Invalid_ident s -> Printf.sprintf "Invalid/unsupported identifier %s" s
+ | Unsupported_type_constructor s -> Printf.sprintf "Unsupported type constructor %s" s
+ | Unmatched_comment -> Printf.sprintf "Unmatched comment"
+ | Unterminated_comment -> Printf.sprintf "Unterminated comment"
+ in
+ Printf.eprintf "%s: %s\n" loc msg;
+ exit 1
+
+let show_parse_error lexbuf =
+ let lxm = lexeme lexbuf in
+ let loc = Printf.sprintf "%s at line %d, char %d"
+ lexbuf.lex_curr_p.pos_fname lexbuf.lex_curr_p.pos_lnum
+ (lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol) in
+ (match lxm with
+ | "" -> Printf.eprintf "%s: parsing error\n" loc
+ | _ -> Printf.eprintf "%s: parsing error at \"%s\"\n" loc lxm);
+ exit 1
+
+let parse_file file =
+ let f = open_in file in
+ let lexbuf = Lexing.from_channel f in
+ try
+ Lexer.init lexbuf file;
+ Parser.defn_list Lexer.main lexbuf
+ with
+ | Syntax_error (e, l) ->
+ show_syntax_error e l
+ | Parsing.Parse_error ->
+ show_parse_error lexbuf
+
+let default_output_filename f =
+ let dir, base = Filename.dirname f, Filename.basename f in
+ let stem = Filename.chop_extension base in
+ Filename.concat dir (stem ^ "_json_conv.ml")
+
+let () =
+ let input = ref "" in
+ let output = ref "" in
+
+ (* parse argv *)
+ let larg = [
+ ("-i", Arg.Set_string input, "input file");
+ ("-o", Arg.Set_string output, "output file");
+ ] in
+ let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
+ Arg.parse larg (fun s -> ()) usage_msg;
+
+ if !output = "" then output := default_output_filename !input;
+
+ match !input with
+ | "" -> Printf.printf "%s\n" usage_msg
+ | file -> Codegen.generate (parse_file file) !output !input
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+{
+
+open Lexing
+open Syntax
+open Parser
+
+let comment_depth = ref 0
+let comment_start = ref dummy_pos
+
+let line_num = ref 0
+
+let init lexbuf fname =
+ lexbuf.lex_curr_p <- { pos_fname = fname;
+ pos_lnum = 1;
+ pos_bol = 0;
+ pos_cnum = 0 }
+
+let raise_syntax_error e loc =
+ raise (Syntax_error (e, loc))
+
+}
+
+let letter = ['A'-'Z' 'a'-'z']
+
+(* The handling of '.' is a bit of a hack for now; not sure if it's
+ really needed. *)
+let ident_first = letter | '_'
+let ident_others = letter | ['0'-'9'] | '_' | '\'' | '.'
+let ident = ident_first ident_others*
+
+rule main = parse
+| [' ' '\009' '\012' '\r']+ { main lexbuf }
+
+| ['\n'] { new_line lexbuf; main lexbuf}
+
+| "*/" { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
+
+| "/*" { comment_depth := 1; comment_start := lexeme_start_p lexbuf;
+ comment lexbuf; main lexbuf }
+
+| eof { EOF }
+| "=" { EQUAL }
+| "*" { STAR }
+| ";" { SEMI }
+| ";;" { SEMISEMI }
+| ":" { COLON }
+| "|" { BAR }
+
+| "{" { LBRACE }
+| "}" { RBRACE }
+| "(" { LPAREN }
+| ")" { RPAREN }
+| "[" { LBRACK }
+| "]" { RBRACK }
+
+| "type" { TYPE }
+| "and" { AND }
+| "mutable" { MUTABLE }
+| "of" { OF }
+
+(* general identifiers. we could handle the '.' here. *)
+| ident
+ { let str = lexeme lexbuf in
+ match String.get str 0 with
+ | 'A' .. 'Z' -> UIDENT str
+ | 'a' .. 'z' -> LIDENT str
+ | _ -> raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
+ }
+| _ { raise_syntax_error (Illegal_character (lexeme_char lexbuf 0)) (lexeme_start_p lexbuf) }
+
+
+and comment = parse
+| "/*" { incr comment_depth; comment lexbuf }
+| "*/" { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
+| ['\n'] { new_line lexbuf; comment lexbuf }
+| eof { raise_syntax_error Unterminated_comment !comment_start }
+| _ { comment lexbuf }
--- /dev/null
+/*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+
+%{
+
+open Syntax
+
+let raise_syntax_error e pos =
+ raise (Syntax_error (e, pos))
+
+%}
+
+/* keywords */
+%token TYPE AND MUTABLE OF
+
+%token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK
+%token EQUAL STAR SEMI SEMISEMI COLON BAR
+%token EOF
+
+%token <string> UIDENT LIDENT
+
+%start defn_list
+
+%type <Syntax.type_defn list> defn_list
+
+%%
+
+defn_list:
+| defns EOF { List.rev $1 }
+;
+
+defns:
+| defns top_defn_term { $2 :: $1 }
+| /* epsilon */ { [] }
+;
+
+top_defn_term:
+| defn semi { $1 }
+
+defn:
+| TYPE eqn { [ $2 ] }
+
+| TYPE eqn AND defn_parts { $2 :: (List.rev $4) }
+
+defn_parts:
+| defn_parts AND eqn { $3 :: $1 }
+| eqn { [ $1 ] }
+
+eqn:
+| LIDENT EQUAL repn { ($1, $3) }
+;
+
+semi:
+| SEMISEMI {}
+| /* epsilon */ {}
+
+repn:
+| expr_or_tuple { $1 }
+| record { C_record (List.rev $1) }
+| variant { C_variant (List.rev $1) }
+
+expr_or_tuple:
+| expr { $1 }
+| expr STAR tuple { C_tuple ($1 :: (List.rev $3)) }
+
+tuple:
+| tuple STAR expr { $3 :: $1 }
+| expr { [ $1 ] }
+
+expr:
+| LPAREN expr_or_tuple RPAREN { $2 }
+
+| expr LIDENT
+ { match $2 with
+ | "option" -> C_option $1
+ | "list" -> C_list $1
+ | "array" -> C_array $1
+ | s -> (raise_syntax_error
+ (Unsupported_type_constructor s)
+ (Parsing.rhs_start_pos 2))
+ }
+| base { C_base $1 }
+
+base:
+| LIDENT { match $1 with
+ | "string" -> B_string
+ | "int" -> B_int
+ | "int64" -> B_int64
+ | "bool" -> B_bool
+ | s -> B_ident s
+ }
+/* TODO:
+| UIDENT { raise_syntax_error (Invalid_ident $1) }
+*/
+
+record:
+| LBRACE field_decls opt_semi RBRACE { $2 }
+
+field_decls:
+| field_decls SEMI field_decl { $3 :: $1 }
+| field_decl { [ $1 ] }
+
+opt_semi:
+| SEMI {}
+| /* epsilon */ {}
+
+field_decl:
+| LIDENT COLON expr_or_tuple { ($1, $3) }
+| MUTABLE LIDENT COLON expr_or_tuple { ($2, $4) }
+
+variant:
+| variant BAR constr { $3 :: $1 }
+| constr { [ $1 ] }
+| /* epsilon */ { [] }
+
+constr:
+| UIDENT { CD_tuple ($1, []) }
+| UIDENT OF expr { CD_tuple ($1, [ $3 ]) }
+
+| UIDENT OF expr STAR tuple { CD_tuple ($1, ($3 :: (List.rev $5))) }
+
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type syntax_error =
+ | Illegal_character of char
+ | Invalid_ident of string
+ | Unsupported_type_constructor of string
+ | Unmatched_comment
+ | Unterminated_comment
+
+exception Syntax_error of syntax_error * Lexing.position
+
+type base_type =
+ | B_string
+ | B_int
+ | B_int64
+ | B_bool
+ | B_ident of string
+
+type complex_type =
+ | C_base of base_type
+ | C_option of complex_type
+ | C_list of complex_type
+ | C_array of complex_type
+ | C_tuple of complex_type list
+ | C_record of (string * complex_type) list
+ | C_variant of constr_decl list
+
+and constr_decl =
+ | CD_tuple of string * complex_type list
+
+type type_defn = (string * complex_type) list
+
--- /dev/null
+.PHONY: clean
+
+OCAMLFLAGS += -I .. -I ../..
+
+test_types_json_conv.ml: test_types.ml $(JSON_CONV)
+ ../$(JSON_CONV_PROG) -i $< -o $@
+
+TESTER_FILES[] =
+ test_types
+ test_types_json_conv
+ test_json_conv
+
+OCAML_LIBS[] +=
+ ../../json
+
+TESTER_PROG = test_json_conv
+TESTER = $(OCamlProgram $(TESTER_PROG), $(TESTER_FILES))
+
+.DEFAULT: $(TESTER)
+
+clean:
+ rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
+
--- /dev/null
+open Test_types
+open Test_types_json_conv
+
+
+let test_list to_j of_j o_list =
+ List.iter (fun t ->
+ let j = to_j t in
+ let o = of_j j in
+ (* Printf.printf "testing of_j(to_j(.) == . for %s\n" (Json.json_to_string j); *)
+ assert (o = t)
+ ) o_list;
+ let j_list = List.map to_j o_list in
+ List.iter (fun t ->
+ let o = of_j t in
+ let j = to_j o in
+ (* Printf.printf "testing to_j(of_j(.) == . for %s\n" (Json.json_to_string j); *)
+ assert (j = t)
+ ) j_list
+
+
+let check_base_type () =
+ let bs = [ B_int 3;
+ B_int64 1L;
+ B_bool false;
+ B_string "test"
+ ] in
+ test_list base_type_to_json base_type_of_json bs
+
+let check_simple_type () =
+ let ss = [ S_int_option None;
+ S_int_option (Some 2);
+ S_int64_option (Some 0L);
+ S_bool_option (Some true);
+ S_string_option (Some "tset");
+
+ S_int_list [ ];
+ S_int_list [ 3; 2; -1 ];
+ S_bool_list [ true; false; false; true; false ];
+ S_int64_list [ 1L; -3L; 2L; 5L];
+ S_string_list [ "iggy"; "franti"; "zappa" ];
+
+ S_int_array [| |];
+ S_int_array [| 1; 3; 2 |];
+ S_bool_array [| false; true; false; false; true |];
+ S_int64_array [| 1L; 3L; -2L; 5L |];
+ S_string_array [| "iggy"; "franti"; "zappa" |]
+ ] in
+ test_list simple_type_to_json simple_type_of_json ss
+
+let check_record_type () =
+ let rs = [ { int = 32;
+ int64 = 32L;
+ bool = false;
+ string = "record";
+
+ int_list = [ 0; 1; 2; -6; 4; 5];
+ int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ bool_array = [| false; true; false; false; true |];
+
+ prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ } ] in
+ test_list record_type_to_json record_type_of_json rs
+
+let check_complex_type1 () =
+ let cs = [ [| |];
+ [| ([], true) |];
+ [| ([4; 3; 1], false); ([1; 3; 4], true) |];
+ ] in
+ test_list complex_type1_to_json complex_type1_of_json cs
+
+let check_complex_type2 () =
+ let cs = [ { record = { int = 32;
+ int64 = 32L;
+ bool = false;
+ string = "record";
+
+ int_list = [ 0; 1; 2; -6; 4; 5];
+ int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
+ bool_array = [| false; true; false; false; true |];
+
+ prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
+ };
+ complex_type1 = [| ([4; 3; 1], false); ([1; 3; 4], true) |];
+ }
+ ] in
+ test_list complex_type2_to_json complex_type2_of_json cs
+
+let _ =
+ check_base_type ();
+ check_simple_type ();
+ check_record_type ();
+ check_complex_type1 ();
+ check_complex_type2 ()
+
--- /dev/null
+
+type base_type =
+ | B_int of int
+ | B_int64 of int64
+ | B_bool of bool
+ | B_string of string
+
+type simple_type =
+ | S_int_option of int option
+ | S_int64_option of int64 option
+ | S_bool_option of bool option
+ | S_string_option of string option
+
+ | S_int_list of int list
+ | S_bool_list of bool list
+ | S_int64_list of int64 list
+ | S_string_list of string list
+
+ | S_int_array of int array
+ | S_bool_array of bool array
+ | S_int64_array of int64 array
+ | S_string_array of string array
+
+type record_type =
+{
+ int: int;
+ int64: int64;
+ bool: bool;
+ string: string;
+
+ int_list: int list;
+ int64_option_array: (int64 option) array;
+ bool_array: bool array;
+
+ prod_list: ((int * bool) list) * string;
+}
+
+
+type complex_type1 = ((int list) * bool) array
+
+type complex_type2 =
+{
+ record: record_type;
+ complex_type1: complex_type1;
+}
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Json
+
+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_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_unexpected_json_type "object" "string"
+ | Json_array _ -> raise_unexpected_json_type "array" "string" in
+ let lenient = function
+ | Json_null _ -> ""
+ | 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_unexpected_json_type "object" "string"
+ | Json_array a ->
+ if Array.length a = 0 then
+ raise_unexpected_json_type "array" "string"
+ else
+ strict a.(0) in
+ if not permissive then strict j else lenient j
+
+let string_to_json s = Json_string s
+
+
+let int_of_json ?(permissive=false) j =
+ let strict = function
+ | 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_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_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_unexpected_json_type "array" "int"
+ else
+ strict a.(0) in
+ if not permissive then strict j else lenient j
+
+let int_to_json i = Json_int (Int64.of_int i)
+
+
+let int64_of_json ?(permissive=false) j =
+ let strict = function
+ | Json_null _ -> raise_unexpected_json_type "null" "int64"
+ | Json_bool _ -> raise_unexpected_json_type "bool" "int64"
+ | Json_int i -> i
+ | 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_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_unexpected_json_type "array" "int64"
+ else
+ strict a.(0) in
+ if not permissive then strict j else lenient j
+
+let int64_to_json i = Json_int i
+
+let bool_of_json ?(permissive=false) j =
+ let strict = function
+ | Json_null _ -> raise_unexpected_json_type "null" "bool"
+ | Json_bool b -> b
+ | 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_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_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
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+
+(* conversion errors *)
+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
+
+
+(* conversion routines for base types *)
+val string_of_json: ?permissive:bool -> Json.t -> string
+val string_to_json: string -> Json.t
+
+val int_of_json: ?permissive:bool -> Json.t -> int
+val int_to_json: int -> Json.t
+
+val int64_of_json: ?permissive:bool -> Json.t -> int64
+val int64_to_json: int64 -> Json.t
+
+val bool_of_json: ?permissive:bool -> Json.t -> bool
+val bool_to_json: bool -> Json.t
+
+(* utilities used by generated code *)
+val raise_unexpected_json_type: string -> string -> 'a
+val raise_short_array: int -> int -> 'a
+val raise_unknown_constructor: string -> string -> 'a
+val check_array_with_length: 'a array -> int -> unit
+val get_variant_constructor: Json.t -> string * Json.t array
+val get_array: Json.t -> Json.t array
+val get_array_elem: Json.t array -> int -> Json.t
+val get_list: Json.t -> Json.t list
+
+type object_table
+val get_object_table: Json.t -> object_table
+val get_object_field: object_table -> string -> Json.t
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-open Syntax
-open Parser
-open Lexing
-
-let show_syntax_error e l =
- let loc = Printf.sprintf "%s at line %d, char %d"
- l.pos_fname l.pos_lnum (l.pos_cnum - l.pos_bol) in
- let msg =
- match e with
- | Illegal_character c -> Printf.sprintf "Illegal character %c" c
- | Invalid_ident s -> Printf.sprintf "Invalid/unsupported identifier %s" s
- | Unsupported_type_constructor s -> Printf.sprintf "Unsupported type constructor %s" s
- | Unmatched_comment -> Printf.sprintf "Unmatched comment"
- | Unterminated_comment -> Printf.sprintf "Unterminated comment"
- in
- Printf.eprintf "%s: %s\n" loc msg;
- exit 1
-
-let show_parse_error lexbuf =
- let lxm = lexeme lexbuf in
- let loc = Printf.sprintf "%s at line %d, char %d"
- lexbuf.lex_curr_p.pos_fname lexbuf.lex_curr_p.pos_lnum
- (lexbuf.lex_curr_p.pos_cnum - lexbuf.lex_curr_p.pos_bol) in
- (match lxm with
- | "" -> Printf.eprintf "%s: parsing error\n" loc
- | _ -> Printf.eprintf "%s: parsing error at \"%s\"\n" loc lxm);
- exit 1
-
-let parse_file file =
- let f = open_in file in
- let lexbuf = Lexing.from_channel f in
- try
- Lexer.init lexbuf file;
- Parser.defn_list Lexer.main lexbuf
- with
- | Syntax_error (e, l) ->
- show_syntax_error e l
- | Parsing.Parse_error ->
- show_parse_error lexbuf
-
-let default_output_filename f =
- let dir, base = Filename.dirname f, Filename.basename f in
- let stem = Filename.chop_extension base in
- Filename.concat dir (stem ^ "_json_conv.ml")
-
-let () =
- let input = ref "" in
- let output = ref "" in
-
- (* parse argv *)
- let larg = [
- ("-i", Arg.Set_string input, "input file");
- ("-o", Arg.Set_string output, "output file");
- ] in
- let usage_msg = Printf.sprintf "%s -i <file> [-o <file>]" Sys.argv.(0) in
- Arg.parse larg (fun s -> ()) usage_msg;
-
- if !output = "" then output := default_output_filename !input;
-
- match !input with
- | "" -> Printf.printf "%s\n" usage_msg
- | file -> Codegen.generate (parse_file file) !output !input
+++ /dev/null
-.PHONY: clean
-
-OCAMLFLAGS += -I ..
-
-test_types_json_conv.ml: test_types.ml $(JSON_CONV)
- ../$(JSON_CONV_PROG) -i $< -o $@
-
-TESTER_FILES[] =
- test_types
- test_types_json_conv
- tester
-
-OCAML_LIBS[] +=
- ../json
-TESTER_PROG = test_conv
-TESTER = $(OCamlProgram $(TESTER_PROG), $(TESTER_FILES))
-
-.DEFAULT: $(TESTER)
-
-clean:
- rm -f $(filter-proper-targets $(ls R, .)) *.annot *.cmo
-
+++ /dev/null
-
-type base_type =
- | B_int of int
- | B_int64 of int64
- | B_bool of bool
- | B_string of string
-
-type simple_type =
- | S_int_option of int option
- | S_int64_option of int64 option
- | S_bool_option of bool option
- | S_string_option of string option
-
- | S_int_list of int list
- | S_bool_list of bool list
- | S_int64_list of int64 list
- | S_string_list of string list
-
- | S_int_array of int array
- | S_bool_array of bool array
- | S_int64_array of int64 array
- | S_string_array of string array
-
-type record_type =
-{
- int: int;
- int64: int64;
- bool: bool;
- string: string;
-
- int_list: int list;
- int64_option_array: (int64 option) array;
- bool_array: bool array;
-
- prod_list: ((int * bool) list) * string;
-}
-
-
-type complex_type1 = ((int list) * bool) array
-
-type complex_type2 =
-{
- record: record_type;
- complex_type1: complex_type1;
-}
+++ /dev/null
-open Test_types
-open Test_types_json_conv
-
-
-let test_list to_j of_j o_list =
- List.iter (fun t ->
- let j = to_j t in
- let o = of_j j in
- (* Printf.printf "testing of_j(to_j(.) == . for %s\n" (Json.json_to_string j); *)
- assert (o = t)
- ) o_list;
- let j_list = List.map to_j o_list in
- List.iter (fun t ->
- let o = of_j t in
- let j = to_j o in
- (* Printf.printf "testing to_j(of_j(.) == . for %s\n" (Json.json_to_string j); *)
- assert (j = t)
- ) j_list
-
-
-let check_base_type () =
- let bs = [ B_int 3;
- B_int64 1L;
- B_bool false;
- B_string "test"
- ] in
- test_list base_type_to_json base_type_of_json bs
-
-let check_simple_type () =
- let ss = [ S_int_option None;
- S_int_option (Some 2);
- S_int64_option (Some 0L);
- S_bool_option (Some true);
- S_string_option (Some "tset");
-
- S_int_list [ ];
- S_int_list [ 3; 2; -1 ];
- S_bool_list [ true; false; false; true; false ];
- S_int64_list [ 1L; -3L; 2L; 5L];
- S_string_list [ "iggy"; "franti"; "zappa" ];
-
- S_int_array [| |];
- S_int_array [| 1; 3; 2 |];
- S_bool_array [| false; true; false; false; true |];
- S_int64_array [| 1L; 3L; -2L; 5L |];
- S_string_array [| "iggy"; "franti"; "zappa" |]
- ] in
- test_list simple_type_to_json simple_type_of_json ss
-
-let check_record_type () =
- let rs = [ { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
-
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
-
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
- } ] in
- test_list record_type_to_json record_type_of_json rs
-
-let check_complex_type1 () =
- let cs = [ [| |];
- [| ([], true) |];
- [| ([4; 3; 1], false); ([1; 3; 4], true) |];
- ] in
- test_list complex_type1_to_json complex_type1_of_json cs
-
-let check_complex_type2 () =
- let cs = [ { record = { int = 32;
- int64 = 32L;
- bool = false;
- string = "record";
-
- int_list = [ 0; 1; 2; -6; 4; 5];
- int64_option_array = [| Some 0L; Some (-3L); None; Some (-1L); Some 5L |];
- bool_array = [| false; true; false; false; true |];
-
- prod_list = [ (1,false); (-23, true); (-1000, true) ], "prod"
- };
- complex_type1 = [| ([4; 3; 1], false); ([1; 3; 4], true) |];
- }
- ] in
- test_list complex_type2_to_json complex_type2_of_json cs
-
-let _ =
- check_base_type ();
- check_simple_type ();
- check_record_type ();
- check_complex_type1 ();
- check_complex_type2 ()
-
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-{
-
-open Lexing
-open Syntax
-open Parser
-
-let comment_depth = ref 0
-let comment_start = ref dummy_pos
-
-let line_num = ref 0
-
-let init lexbuf fname =
- lexbuf.lex_curr_p <- { pos_fname = fname;
- pos_lnum = 1;
- pos_bol = 0;
- pos_cnum = 0 }
-
-let raise_syntax_error e loc =
- raise (Syntax_error (e, loc))
-
-}
-
-let letter = ['A'-'Z' 'a'-'z']
-
-(* The handling of '.' is a bit of a hack for now; not sure if it's
- really needed. *)
-let ident_first = letter | '_'
-let ident_others = letter | ['0'-'9'] | '_' | '\'' | '.'
-let ident = ident_first ident_others*
-
-rule main = parse
-| [' ' '\009' '\012' '\r']+ { main lexbuf }
-
-| ['\n'] { new_line lexbuf; main lexbuf}
-
-| "*/" { raise_syntax_error Unmatched_comment (lexeme_start_p lexbuf) }
-
-| "/*" { comment_depth := 1; comment_start := lexeme_start_p lexbuf;
- comment lexbuf; main lexbuf }
-
-| eof { EOF }
-| "=" { EQUAL }
-| "*" { STAR }
-| ";" { SEMI }
-| ";;" { SEMISEMI }
-| ":" { COLON }
-| "|" { BAR }
-
-| "{" { LBRACE }
-| "}" { RBRACE }
-| "(" { LPAREN }
-| ")" { RPAREN }
-| "[" { LBRACK }
-| "]" { RBRACK }
-
-| "type" { TYPE }
-| "and" { AND }
-| "mutable" { MUTABLE }
-| "of" { OF }
-
-(* general identifiers. we could handle the '.' here. *)
-| ident
- { let str = lexeme lexbuf in
- match String.get str 0 with
- | 'A' .. 'Z' -> UIDENT str
- | 'a' .. 'z' -> LIDENT str
- | _ -> raise_syntax_error (Invalid_ident str) (lexeme_start_p lexbuf)
- }
-| _ { raise_syntax_error (Illegal_character (lexeme_char lexbuf 0)) (lexeme_start_p lexbuf) }
-
-
-and comment = parse
-| "/*" { incr comment_depth; comment lexbuf }
-| "*/" { decr comment_depth; if !comment_depth > 0 then comment lexbuf }
-| ['\n'] { new_line lexbuf; comment lexbuf }
-| eof { raise_syntax_error Unterminated_comment !comment_start }
-| _ { comment lexbuf }
+++ /dev/null
-/*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- */
-
-
-%{
-
-open Syntax
-
-let raise_syntax_error e pos =
- raise (Syntax_error (e, pos))
-
-%}
-
-/* keywords */
-%token TYPE AND MUTABLE OF
-
-%token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK
-%token EQUAL STAR SEMI SEMISEMI COLON BAR
-%token EOF
-
-%token <string> UIDENT LIDENT
-
-%start defn_list
-
-%type <Syntax.type_defn list> defn_list
-
-%%
-
-defn_list:
-| defns EOF { List.rev $1 }
-;
-
-defns:
-| defns top_defn_term { $2 :: $1 }
-| /* epsilon */ { [] }
-;
-
-top_defn_term:
-| defn semi { $1 }
-
-defn:
-| TYPE eqn { [ $2 ] }
-
-| TYPE eqn AND defn_parts { $2 :: (List.rev $4) }
-
-defn_parts:
-| defn_parts AND eqn { $3 :: $1 }
-| eqn { [ $1 ] }
-
-eqn:
-| LIDENT EQUAL repn { ($1, $3) }
-;
-
-semi:
-| SEMISEMI {}
-| /* epsilon */ {}
-
-repn:
-| expr_or_tuple { $1 }
-| record { C_record (List.rev $1) }
-| variant { C_variant (List.rev $1) }
-
-expr_or_tuple:
-| expr { $1 }
-| expr STAR tuple { C_tuple ($1 :: (List.rev $3)) }
-
-tuple:
-| tuple STAR expr { $3 :: $1 }
-| expr { [ $1 ] }
-
-expr:
-| LPAREN expr_or_tuple RPAREN { $2 }
-
-| expr LIDENT
- { match $2 with
- | "option" -> C_option $1
- | "list" -> C_list $1
- | "array" -> C_array $1
- | s -> (raise_syntax_error
- (Unsupported_type_constructor s)
- (Parsing.rhs_start_pos 2))
- }
-| base { C_base $1 }
-
-base:
-| LIDENT { match $1 with
- | "string" -> B_string
- | "int" -> B_int
- | "int64" -> B_int64
- | "bool" -> B_bool
- | s -> B_ident s
- }
-/* TODO:
-| UIDENT { raise_syntax_error (Invalid_ident $1) }
-*/
-
-record:
-| LBRACE field_decls opt_semi RBRACE { $2 }
-
-field_decls:
-| field_decls SEMI field_decl { $3 :: $1 }
-| field_decl { [ $1 ] }
-
-opt_semi:
-| SEMI {}
-| /* epsilon */ {}
-
-field_decl:
-| LIDENT COLON expr_or_tuple { ($1, $3) }
-| MUTABLE LIDENT COLON expr_or_tuple { ($2, $4) }
-
-variant:
-| variant BAR constr { $3 :: $1 }
-| constr { [ $1 ] }
-| /* epsilon */ { [] }
-
-constr:
-| UIDENT { CD_tuple ($1, []) }
-| UIDENT OF expr { CD_tuple ($1, [ $3 ]) }
-
-| UIDENT OF expr STAR tuple { CD_tuple ($1, ($3 :: (List.rev $5))) }
-
#!/bin/bash
-PROG=../test_parser
+PROG=./test_parser
for f in `ls *pass*.json`; do
$PROG $f > /dev/null 2>&1
--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+let options = [ ]
+
+let parse_args () =
+ let file = ref None in
+ let usage = Printf.sprintf "Usage: %s file" Sys.argv.(0) in
+ Arg.parse (Arg.align options) (fun f -> file := Some f) usage;
+ match !file with
+ | Some f -> f
+ | None -> Printf.eprintf "%s\n" usage; exit 1
+
+let read_whole_file ic =
+ let buf = Buffer.create 512 in
+ let rec do_read () =
+ try
+ let line = input_line ic in
+ Buffer.add_string buf line;
+ do_read ()
+ with End_of_file ->
+ Buffer.contents buf
+ in do_read ()
+
+let parse_file f =
+ let ic = open_in f in
+ let input = ref (read_whole_file ic) in
+ let state = ref (Json_parse.init_parse_state ()) in
+ while String.length !input > 0 do
+ match Json_parse.parse !state !input with
+ | Json_parse.Json_value (v, rem) ->
+ Printf.printf "%s\n" (Json.json_to_string v);
+ input := rem;
+ state := Json_parse.init_parse_state ()
+ | Json_parse.Json_parse_incomplete st ->
+ input := "";
+ state := st
+ done;
+ match Json_parse.finish_parse !state with
+ | Some v -> Printf.printf "%s\n" (Json.json_to_string v)
+ | None -> ()
+
+let print_exception e =
+ match e with
+ | Json_parse.Unexpected_char (c, state) ->
+ Printf.eprintf "Unexpected char %C (x%X) encountered in state %s\n"
+ c (Char.code c) state
+ | Json_parse.Invalid_value (v, t) ->
+ Printf.eprintf "'%s' is an invalid %s\n" v t
+ | Json_parse.Invalid_leading_zero s ->
+ Printf.eprintf "'%s' should not have leading zeros\n" s
+ | Json_parse.Unterminated_value s ->
+ Printf.eprintf "unterminated %s\n" s
+ | Json_parse.Internal_error m ->
+ Printf.eprintf "Internal error: %s\n" m
+ | Sys_error s ->
+ Printf.eprintf "%s\n" s
+ | e ->
+ Printf.eprintf "%s\n" (Printexc.to_string e)
+
+let is_internal_error = function
+ | Json_parse.Internal_error _ -> true
+ | _ -> false
+
+let _ =
+ let input_file = parse_args () in
+ try
+ parse_file input_file;
+ exit 0
+ with e ->
+ print_exception e;
+ if is_internal_error e then exit 255 else exit 1
+
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-type syntax_error =
- | Illegal_character of char
- | Invalid_ident of string
- | Unsupported_type_constructor of string
- | Unmatched_comment
- | Unterminated_comment
-
-exception Syntax_error of syntax_error * Lexing.position
-
-type base_type =
- | B_string
- | B_int
- | B_int64
- | B_bool
- | B_ident of string
-
-type complex_type =
- | C_base of base_type
- | C_option of complex_type
- | C_list of complex_type
- | C_array of complex_type
- | C_tuple of complex_type list
- | C_record of (string * complex_type) list
- | C_variant of constr_decl list
-
-and constr_decl =
- | CD_tuple of string * complex_type list
-
-type type_defn = (string * complex_type) list
-
+++ /dev/null
-(*
- * Copyright (C) 2009 Citrix Ltd.
- * Author Prashanth Mundkur <firstname.lastname@citrix.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published
- * by the Free Software Foundation; version 2.1 only. with the special
- * exception on linking described in file LICENSE.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU Lesser General Public License for more details.
- *)
-
-let options = [ ]
-
-let parse_args () =
- let file = ref None in
- let usage = Printf.sprintf "Usage: %s file" Sys.argv.(0) in
- Arg.parse (Arg.align options) (fun f -> file := Some f) usage;
- match !file with
- | Some f -> f
- | None -> Printf.eprintf "%s\n" usage; exit 1
-
-let read_whole_file ic =
- let buf = Buffer.create 512 in
- let rec do_read () =
- try
- let line = input_line ic in
- Buffer.add_string buf line;
- do_read ()
- with End_of_file ->
- Buffer.contents buf
- in do_read ()
-
-let parse_file f =
- let ic = open_in f in
- let input = ref (read_whole_file ic) in
- let state = ref (Json_parse.init_parse_state ()) in
- while String.length !input > 0 do
- match Json_parse.parse !state !input with
- | Json_parse.Json_value (v, rem) ->
- Printf.printf "%s\n" (Json.json_to_string v);
- input := rem;
- state := Json_parse.init_parse_state ()
- | Json_parse.Json_parse_incomplete st ->
- input := "";
- state := st
- done;
- match Json_parse.finish_parse !state with
- | Some v -> Printf.printf "%s\n" (Json.json_to_string v)
- | None -> ()
-
-let print_exception e =
- match e with
- | Json_parse.Unexpected_char (c, state) ->
- Printf.eprintf "Unexpected char %C (x%X) encountered in state %s\n"
- c (Char.code c) state
- | Json_parse.Invalid_value (v, t) ->
- Printf.eprintf "'%s' is an invalid %s\n" v t
- | Json_parse.Invalid_leading_zero s ->
- Printf.eprintf "'%s' should not have leading zeros\n" s
- | Json_parse.Unterminated_value s ->
- Printf.eprintf "unterminated %s\n" s
- | Json_parse.Internal_error m ->
- Printf.eprintf "Internal error: %s\n" m
- | Sys_error s ->
- Printf.eprintf "%s\n" s
- | e ->
- Printf.eprintf "%s\n" (Printexc.to_string e)
-
-let is_internal_error = function
- | Json_parse.Internal_error _ -> true
- | _ -> false
-
-let _ =
- let input_file = parse_args () in
- try
- parse_file input_file;
- exit 0
- with e ->
- print_exception e;
- if is_internal_error e then exit 255 else exit 1
-
projects / xenclient / toolstack.git / commitdiff