From dee51d0eea69c205100668da711d871c9e8dd5f1 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 04:40:19 -0800 Subject: [PATCH 1/7] remove json parsing in favour of ezjsonm still WIP --- lib/json.ml | 451 +++------------------------------------------------ lib/json.mli | 11 +- 2 files changed, 22 insertions(+), 440 deletions(-) diff --git a/lib/json.ml b/lib/json.ml index be092c1..c3d552f 100644 --- a/lib/json.ml +++ b/lib/json.ml @@ -13,16 +13,9 @@ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) +*) -type t = - | Int of int64 - | Bool of bool - | Float of float - | String of string - | Array of t list - | Object of (string * t) list - | Null +type t = Ezjsonm.t let rec list_iter_between f o = function | [] -> () @@ -51,37 +44,35 @@ let escape_string s = Buffer.add_string buf "\""; Buffer.contents buf -let rec to_fct t f = +let rec to_fct (t : t) f = match t with - | Int i -> f (Printf.sprintf "%Ld" i) - | Bool b -> f (string_of_bool b) - | Float r -> f (Printf.sprintf "%g" r) - | String s -> f (escape_string s) - | Null -> f "null" - | Array a -> + | `Bool b -> f (string_of_bool b) + | `Float r -> f (Printf.sprintf "%g" r) + | `String s -> f (escape_string s) + | `Null -> f "null" + | `A a -> f "["; list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a; f "]"; - | Object a -> + | `O a -> f "{"; - list_iter_between (fun (k, v) -> to_fct (String k) f; f ": "; to_fct v f) + list_iter_between (fun (k, v) -> to_fct (`String k) f; f ": "; to_fct v f) (fun () -> f ", ") a; f "}" -let rec to_fct_hum t f = +let rec to_fct_hum (t : t) f = match t with - | Int i -> f (Printf.sprintf "%Ld" i) - | Bool b -> f (string_of_bool b) - | Float r -> f (Printf.sprintf "%g" r) - | String s -> f (escape_string s) - | Null -> f "null" - | Array a -> + | `Bool b -> f (string_of_bool b) + | `Float r -> f (Printf.sprintf "%g" r) + | `String s -> f (escape_string s) + | `Null -> f "null" + | `A a -> f "[ "; list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a; f " ]\n"; - | Object a -> + | `O a -> f "{"; - list_iter_between (fun (k, v) -> to_fct (String k) f; f ": "; to_fct v f) + list_iter_between (fun (k, v) -> to_fct (`String k) f; f ": "; to_fct v f) (fun () -> f ", ") a; f "}\n" @@ -89,411 +80,11 @@ let rec to_fct_hum t f = let to_buffer t buf = to_fct t (fun s -> Buffer.add_string buf s) -let to_string t = - let buf = Buffer.create 1024 in - to_buffer t buf; - Buffer.contents buf +let to_string = Ezjsonm.to_string ~minify:true let to_buffer_hum t buf = to_fct_hum t (fun s -> Buffer.add_string buf s) -let to_string_hum t = - let buf = Buffer.create 1024 in - to_buffer_hum t buf; - Buffer.contents buf - -let new_id = - let count = ref 0L in - (fun () -> count := Int64.add 1L !count; !count) - -type error = - | Unexpected_char of int * char * (* json type *) string - | Invalid_value of int * (* value *) string * (* json type *) string - | Invalid_leading_zero of int * string - | Unterminated_value of int * string - | Internal_error of int * string - -exception Parse_error of error - -module Parser = struct - - type cursor = - | Start - | Expect_value - | In_null of int - | In_true of int - | In_false of int - | In_int of char list - | In_float of char list * char list - | In_int_exp of char list * char list - | In_float_exp of char list * char list * char list - | In_string of char list - | In_string_control of char list - | In_string_hex of char list * char list * int - | Expect_object_elem_start - | Expect_object_elem_colon - | Expect_comma_or_end - | Expect_object_key - | Done of t - - type int_value = - | IObject of (string * t) list - | IObject_needs_key of (string * t) list - | IObject_needs_value of (string * t) list * string - | IArray of t list - - type parse_state = { - mutable cursor: cursor; - mutable stack: int_value list; - mutable num_chars_parsed: int; - mutable line_num: int - } - - let init_parse_state () = { - cursor = Start; - stack = []; - num_chars_parsed = 0; - line_num = 1 - } - - let is_parsing_object s = - match s.stack with - | IObject _ :: _ | IObject_needs_key _ :: _ | IObject_needs_value _ :: _ -> true - | IArray _ :: _ - | [] -> false - - let get_parse_result s = - match s.cursor with - | Done v -> Some v - | _ -> None - - let ivalue_to_str = function - | IObject _ -> "object" - | IObject_needs_key _ -> "object_needing_key" - | IObject_needs_value _ -> "object_needing_value" - | IArray _ -> "array" - - let current_cursor_value = function - | Start | Expect_value -> "value" - | In_null _ -> "null" - | In_true _ | In_false _ -> "boolean" - | In_int _ | In_float _ | In_int_exp _ | In_float_exp _ -> "number" - | In_string _ | In_string_control _ | In_string_hex _ -> "string" - | Expect_object_elem_start | Expect_object_elem_colon | Expect_object_key -> "object" - | Expect_comma_or_end -> "object/array" - | Done _ -> "" - - let is_space c = c = ' ' || c = '\t' || c = '\n' || c = '\r' - - let update_line_num s c = - if c = '\n' then - s.line_num <- s.line_num + 1 - - let is_hex_char = function - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - - let is_valid_unescaped_char c = - match c with - | '"' | '\\' | '\b' | '\x0c' | '\n' | '\r' | '\t' -> false - | _ -> true - - let clist_to_string cs = - let len = List.length cs in - let s = String.create len in - let rec iter indx = function - | c :: cs -> - String.set s indx c; - iter (indx + 1) cs - | [] -> () in - iter 0 cs; - s - - let string_of_error = function - | Unexpected_char (l, c, state) -> - Printf.sprintf "Line %d: Unexpected char %C (x%X) encountered in state %s" - l c (Char.code c) state - | Invalid_value (l, v, t) -> - Printf.sprintf "Line %d: '%s' is an invalid %s" l v t - | Invalid_leading_zero (l, s) -> - Printf.sprintf "Line %d: '%s' should not have leading zeros" l s - | Unterminated_value (l, s) -> - Printf.sprintf "Line %d: unterminated %s" l s - | Internal_error (l, m) -> - Printf.sprintf "Line %d: Internal error: %s" l m - - let raise_unexpected_char s c t = - raise (Parse_error (Unexpected_char (s.line_num, c, t))) - let raise_invalid_value s v t = - raise (Parse_error (Invalid_value (s.line_num, v, t))) - let raise_invalid_leading_zero s n = - raise (Parse_error (Invalid_leading_zero (s.line_num, n))) - let raise_unterminated_value s v = - raise (Parse_error (Unterminated_value (s.line_num, v))) - let raise_internal_error s m = - raise (Parse_error (Internal_error (s.line_num, m))) - - let finish_value s v = - match s.stack, v with - | [], _ -> s.cursor <- Done v - | IObject_needs_key fields :: tl, String key -> - s.stack <- IObject_needs_value (fields, key) :: tl; - s.cursor <- Expect_object_elem_colon - | IObject_needs_value (fields, key) :: tl, _ -> - s.stack <- IObject ((key, v) :: fields) :: tl; - s.cursor <- Expect_comma_or_end - | IArray l :: tl, _ -> - s.stack <- IArray (v :: l) :: tl; - s.cursor <- Expect_comma_or_end - | io :: tl, _ -> - raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at finish_value") - - let pop_stack s = - match s.stack with - | IObject fields :: tl -> s.stack <- tl; finish_value s (Object (List.rev fields)) - | IArray l :: tl -> s.stack <- tl; finish_value s (Array (List.rev l)) - | io :: tl -> raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at pop_stack") - | [] -> raise_internal_error s "empty stack at pop_stack" - - let rec parse_char s c = - (* Printf.printf "parsing %C at line %d in state %s...\n" c s.line_num (current_cursor_value s.cursor); *) - let tostring_with_leading_zero_check is = - let ris = List.rev is in - let check = function - | [] | [ '0' ] -> () - | '0' :: tl when List.length tl > 0 -> - raise_invalid_leading_zero s (clist_to_string ris) - | _ -> () in - check ris; - clist_to_string ris in - let finish_int is = - let str = tostring_with_leading_zero_check is in - let int = try Int64.of_string str - with Failure _ -> raise_invalid_value s str "int" in - finish_value s (Int int) in - let finish_int_exp is es = - let int = tostring_with_leading_zero_check is in - let exp = clist_to_string (List.rev es) in - let str = Printf.sprintf "%s.e%s" int exp in - (* If exp is positive, we might actually - succeed in making this an int, but - returning float is more uniform. *) - let float = try float_of_string str - with Failure _ -> raise_invalid_value s str "float" in - finish_value s (Float float) in - let finish_float is fs = - let int = tostring_with_leading_zero_check is in - let frac = clist_to_string (List.rev fs) in - let str = Printf.sprintf "%s.%s" int frac in - let float = try float_of_string str - with Failure _ -> raise_invalid_value s str "float" in - finish_value s (Float float) in - let finish_float_exp is fs es = - let int = tostring_with_leading_zero_check is in - let frac = clist_to_string (List.rev fs) in - let exp = clist_to_string (List.rev es) in - let str = Printf.sprintf "%s.%se%s" int frac exp in - let float = try float_of_string str - with Failure _ -> raise_invalid_value s str "float" in - finish_value s (Float float) in - - match s.cursor with - | Start -> - (match c with - | 'n' -> s.cursor <- In_null 3 - | 't' -> s.cursor <- In_true 3 - | 'f' -> s.cursor <- In_false 4 - | '-' | '0' .. '9' -> s.cursor <- In_int [c] - | '"' -> s.cursor <- In_string [] - | '{' -> s.cursor <- Expect_object_elem_start - | '[' -> s.stack <- (IArray []) :: s.stack - | ']' when s.stack <> [] -> pop_stack s - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "start") - - | Expect_value -> - (match c with - | 'n' -> s.cursor <- In_null 3 - | 't' -> s.cursor <- In_true 3 - | 'f' -> s.cursor <- In_false 4 - | '-' | '0' .. '9' -> s.cursor <- In_int [c] - | '"' -> s.cursor <- In_string [] - | '{' -> s.cursor <- Expect_object_elem_start - | '[' -> s.stack <- (IArray []) :: s.stack; s.cursor <- Start - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "value") - - | In_null rem -> - (match c, rem with - | 'u', 3 -> s.cursor <- In_null 2 - | 'l', 2 -> s.cursor <- In_null 1 - | 'l', 1 -> finish_value s Null - | _ -> raise_unexpected_char s c "null") - - | In_true rem -> - (match c, rem with - | 'r', 3 -> s.cursor <- In_true 2 - | 'u', 2 -> s.cursor <- In_true 1 - | 'e', 1 -> finish_value s (Bool true) - | _ -> raise_unexpected_char s c "true") - - | In_false rem -> - (match c, rem with - | 'a', 4 -> s.cursor <- In_false 3 - | 'l', 3 -> s.cursor <- In_false 2 - | 's', 2 -> s.cursor <- In_false 1 - | 'e', 1 -> finish_value s (Bool false) - | _ -> raise_unexpected_char s c "false") - - | In_int is -> - (match c with - | '0' .. '9' -> s.cursor <- In_int (c :: is) - | '.' -> s.cursor <- In_float (is, []) - | 'e' | 'E' -> s.cursor <- In_int_exp (is, []) - | ',' | ']' | '}' -> finish_int is; parse_char s c - | _ when is_space c -> update_line_num s c; finish_int is - | _ -> raise_unexpected_char s c "int") - - | In_float (is, fs) -> - (match c with - | '0' .. '9' -> s.cursor <- In_float (is, c :: fs) - | 'e' | 'E' -> s.cursor <- In_float_exp (is, fs, []) - | ',' | ']' | '}' -> finish_float is fs; parse_char s c - | _ when is_space c -> update_line_num s c; finish_float is fs - | _ -> raise_unexpected_char s c "float") - - | In_int_exp (is, es) -> - (match c with - | '+' | '-' | '0' .. '9' -> s.cursor <- In_int_exp (is, c :: es) - | ',' | ']' | '}' -> finish_int_exp is es; parse_char s c - | _ when is_space c -> update_line_num s c; finish_int_exp is es - | _ -> raise_unexpected_char s c "int_exp") - - | In_float_exp (is, fs, es) -> - (match c with - | '+' | '-' | '0' .. '9' -> s.cursor <- In_float_exp (is, fs, c :: es) - | ',' | ']' | '}' -> finish_float_exp is fs es; parse_char s c - | _ when is_space c -> update_line_num s c; finish_float_exp is fs es - | _ -> raise_unexpected_char s c "float_exp") - - | In_string cs -> - (match c with - | '\\' -> s.cursor <- In_string_control cs - | '"' -> finish_value s (String (clist_to_string (List.rev cs))) - | _ when is_valid_unescaped_char c -> s.cursor <- In_string (c :: cs) - | _ -> raise_unexpected_char s c "string") - - | In_string_control cs -> - (match c with - | '"' | '\\' | '/' -> s.cursor <- In_string (c :: cs) - | 'b' -> s.cursor <- In_string ('\b' :: cs) - | 'f' -> s.cursor <- In_string ('\x0c' :: cs) - | 'n' -> s.cursor <- In_string ('\n' :: cs) - | 'r' -> s.cursor <- In_string ('\r' :: cs) - | 't' -> s.cursor <- In_string ('\t' :: cs) - | 'u' -> s.cursor <- In_string_hex (cs, [], 4) - | _ -> raise_unexpected_char s c "string_control") - - | In_string_hex (cs, hs, rem) -> - if is_hex_char c then begin - let hs = c :: hs in - if rem > 1 then - s.cursor <- In_string_hex (cs, hs, rem - 1) - else - (* TODO: We currently just leave the unicode escapes in place. *) - s.cursor <- In_string (hs @ ('u' :: '\\' :: cs)) - end else - raise_unexpected_char s c "string_unicode" - - | Expect_object_elem_start -> - (match c with - | '"' -> s.stack <- (IObject_needs_key []) :: s.stack; s.cursor <- In_string [] - | '}' -> finish_value s (Object []) - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "object_start") - - | Expect_object_elem_colon -> - (match c with - | ':' -> s.cursor <- Start - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "object_elem_colon") - - | Expect_comma_or_end -> - (match c with - | ',' when is_parsing_object s -> s.cursor <- Expect_object_key - | ',' -> s.cursor <- Expect_value - | '}' when is_parsing_object s -> pop_stack s - | '}' -> raise_unexpected_char s c "comma_or_end" - | ']' when not (is_parsing_object s) -> pop_stack s - | ']' -> raise_unexpected_char s c "comma_or_end" - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "comma_or_end") - - | Expect_object_key -> - (match c with - | '"' -> - (match s.stack with - | IObject fields :: tl -> s.stack <- IObject_needs_key fields :: tl - | io :: _ -> raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at object_key") - | [] -> raise_internal_error s "empty stack at object_key"); - s.cursor <- In_string [] - | _ when is_space c -> update_line_num s c - | _ -> raise_unexpected_char s c "object_key") - - | Done _ -> raise_internal_error s "parse called when parse_state is 'Done'" - - type parse_result = - | Json_value of t - | Json_parse_incomplete of parse_state - - let parse state str = - while get_parse_result state = None do - parse_char state (str ()); - (* This is here instead of inside parse_char since - parse_char makes (tail-)recursive calls without - consuming a character. - *) - state.num_chars_parsed <- state.num_chars_parsed + 1; - done; - match get_parse_result state with - | Some v -> Json_value v - | None -> Json_parse_incomplete state - - (* This is really only required for numbers, since they are only - terminated by whitespace, but end-of-file or end-of-connection - qualifies as whitespace. - - The parser might also be just eating whitespace, expecting the - start of a json value. - *) - let finish_parse state = - match parse state (fun () -> ' ') with - | Json_value v -> Some v - | Json_parse_incomplete _ -> - if state.cursor = Start then None - else raise_unterminated_value state (current_cursor_value state.cursor) - - let num_chars_parsed state = state.num_chars_parsed - - let of_stream str = - match parse (init_parse_state ()) str with - | Json_value v -> v - | Json_parse_incomplete st -> - match finish_parse st with - | Some v -> v - | None -> raise_unterminated_value st (current_cursor_value st.cursor) - - let of_string str = - let i = ref (-1) in - let next () = - incr i; - str.[ !i ] in - of_stream next -end - -let of_string = Parser.of_string - -exception Malformed_method_request of string -exception Malformed_method_response of string +let to_string_hum = Ezjsonm.to_string ~minify:false -exception Runtime_error of string * t +let of_string = Ezjsonm.from_string diff --git a/lib/json.mli b/lib/json.mli index b4c5707..3499791 100644 --- a/lib/json.mli +++ b/lib/json.mli @@ -15,14 +15,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t = - | Int of int64 - | Bool of bool - | Float of float - | String of string - | Array of t list - | Object of (string * t) list - | Null +type t = Ezjsonm.t val to_buffer : t -> Buffer.t -> unit val to_string : t -> string @@ -31,5 +24,3 @@ val to_buffer_hum : t -> Buffer.t -> unit val to_string_hum : t -> string val of_string : string -> t - -exception Runtime_error of string * t From 771194371bfbe57689ae2bb0ef97e4843e6229f3 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 04:41:01 -0800 Subject: [PATCH 2/7] update build scripts and META --- META.in | 6 +++--- _vars | 2 +- cmd | 1 + tests/Makefile | 4 ++-- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/META.in b/META.in index 2f6ed25..30ac151 100644 --- a/META.in +++ b/META.in @@ -3,11 +3,11 @@ description = "Caml on the Web" archive(byte) = "cow.cma" archive(native) = "cow.cmxa" exists_if = "cow.cma" -requires = "dyntype dyntype.syntax re re.str ulex uri xmlm omd" +requires = "dyntype dyntype.syntax ezjsonm re re.str ulex uri xmlm omd" package "syntax" ( description = "Syntax extension for COW" - requires = "camlp4 str dyntype.syntax xmlm" - archive(syntax, preprocessor) = "xmlm.cma str.cma pa_cow.cma" + requires = "camlp4 str dyntype.syntax xmlm ezjsonm" + archive(syntax, preprocessor) = "xmlm.cma str.cma pa_cow.cma ezjsonm.cma" archive(syntax, toploop) = "pa_cow.cma" exists_if = "pa_cow.cma" ) diff --git a/_vars b/_vars index 6896401..5975880 100644 --- a/_vars +++ b/_vars @@ -2,4 +2,4 @@ NAME=cow VERSION=0.9.1 LIB=cow SYNTAX="pa_cow" -DEPS="dyntype.syntax dyntype re ulex uri xmlm omd" +DEPS="dyntype.syntax dyntype re ulex uri xmlm omd ezjsonm" diff --git a/cmd b/cmd index 48e8e1d..26d37d2 100755 --- a/cmd +++ b/cmd @@ -35,6 +35,7 @@ configure() { # specially needed for syntax TODO merge with _vars ${OCAMLFIND} query -r -predicates byte -format '-I %d %A' str >> _config/syntax.deps ${OCAMLFIND} query -r -predicates byte -format '-I %d %A' xmlm >> _config/syntax.deps + ${OCAMLFIND} query -r -predicates byte -format '-I %d %A' ezjsonm >> _config/syntax.deps # _config/syntax has flags to build p4 extensions in syntax/ ${OCAMLFIND} query -r -predicates syntax,preprocessor -format '-I %d' camlp4.quotations.o camlp4.lib camlp4.extend > _config/syntax.build ${OCAMLFIND} query -r -predicates syntax,preprocessor -format '-I %d' camlp4.quotations.r camlp4.lib camlp4.extend ${SYNTAX_DEPS} > _config/syntax.build.r diff --git a/tests/Makefile b/tests/Makefile index cd63f23..9270a90 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,5 +1,5 @@ -P4OPTS = $(shell ocamlfind query str dyntype dyntype.syntax re re.str ulex xmlm -predicates syntax,preprocessor,byte -r -format "-I %d %a") -OPTS = $(shell ocamlfind query dyntype re re.str ulex oUnit uri xmlm omd -predicates archives,byte -r -format "-I %d %a") +P4OPTS = $(shell ocamlfind query str dyntype dyntype.syntax re re.str ulex xmlm ezjsonm -predicates syntax,preprocessor,byte -r -format "-I %d %a") +OPTS = $(shell ocamlfind query dyntype re re.str ulex oUnit uri xmlm ezjsonm omd -predicates archives,byte -r -format "-I %d %a") TEST = render #tc_marshall PP = $(TEST:%=%_pp.ml) From dcac9106c4011284fecefcce62d6cdf96879cefa Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 04:41:22 -0800 Subject: [PATCH 3/7] update deps in travis --- .travis-ci.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis-ci.sh b/.travis-ci.sh index 7cf86ba..3372e85 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -1,4 +1,4 @@ -OPAM_DEPENDS="re ulex uri xmlm dyntype ounit omd" +OPAM_DEPENDS="re ulex uri xmlm ezjsonm dyntype ounit omd" case "$OCAML_VERSION,$OPAM_VERSION" in 3.12.1,1.0.0) ppa=avsm/ocaml312+opam10 ;; From c7a5cda13ca8698377746303314c0424db568211 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 04:43:56 -0800 Subject: [PATCH 4/7] include ezjsonm in json --- lib/json.ml | 2 +- lib/json.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/json.ml b/lib/json.ml index c3d552f..c2a487a 100644 --- a/lib/json.ml +++ b/lib/json.ml @@ -15,7 +15,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t = Ezjsonm.t +include Ezjsonm let rec list_iter_between f o = function | [] -> () diff --git a/lib/json.mli b/lib/json.mli index 3499791..7c68b28 100644 --- a/lib/json.mli +++ b/lib/json.mli @@ -15,7 +15,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -type t = Ezjsonm.t +include module type of Ezjsonm val to_buffer : t -> Buffer.t -> unit val to_string : t -> string From 09e08cc88abb3683133c53a9848483b7daccf344 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 05:18:03 -0800 Subject: [PATCH 5/7] mechanical conversions old json -> ezjsonm --- syntax/json/extension.ml | 56 ++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/syntax/json/extension.ml b/syntax/json/extension.ml index f526ba0..ee8b048 100644 --- a/syntax/json/extension.ml +++ b/syntax/json/extension.ml @@ -91,23 +91,23 @@ module Json_of = struct <:expr< Json.Int $id$ >> | Int _ -> - <:expr< Json.String (Bigint.to_string $id$) >> + <:expr< `String (Bigint.to_string $id$) >> | List (Tuple [String; t ]) -> (* XXX: deal with `type a = string type t = (a * int) list` *) let pid, eid = new_id _loc () in - <:expr< Json.Object (List.map (fun (s, $pid$) -> (s, $aux eid t$)) t) >> + <:expr< `O (List.map (fun (s, $pid$) -> (s, $aux eid t$)) t) >> | List t -> let pid, eid = new_id _loc () in - <:expr< Json.Array (List.map (fun $pid$ -> $aux eid t$) $id$) >> + <:expr< `A (List.map (fun $pid$ -> $aux eid t$) $id$) >> | Array (Tuple [String; t ]) -> (* XXX: deal with `type a = string type t = (a * int) array` *) let pid, eid = new_id _loc () in - <:expr< Json.Object (Array.to_list (Array.map (fun (s, $pid$) -> (s, $aux eid t$)) $id$)) >> + <:expr< `O (Array.to_list (Array.map (fun (s, $pid$) -> (s, $aux eid t$)) $id$)) >> | Array t -> let pid, eid = new_id _loc () in - <:expr< Json.Array (Array.to_list (Array.map (fun $pid$ -> $aux eid t$) $id$)) >> + <:expr< `A (Array.to_list (Array.map (fun $pid$ -> $aux eid t$) $id$)) >> | Tuple t -> let ids = List.map (new_id _loc) t in @@ -115,7 +115,7 @@ module Json_of = struct let exprs = List.map2 aux exprs t in <:expr< let $patt_tuple_of_list _loc patts$ = $id$ in - Json.Array $expr_list_of_list _loc exprs$ + `A $expr_list_of_list _loc exprs$ >> | Dict (k,d) -> @@ -129,17 +129,17 @@ module Json_of = struct | (n,_,t) -> (`Regular, <:expr< ($`str:n$, $aux (new_id n) t$) >>)) d in let expr = expr_list_of_opt_list _loc exprs in - <:expr< Json.Object $expr$ >> + <:expr< `O $expr$ >> | Sum (k, s) -> let mc (n, args) = let ids = List.map (new_id _loc) args in let patts, exprs = List.split ids in let exprs = match args with - | [] -> <:expr< Json.String $str:n$ >> + | [] -> <:expr< `String $str:n$ >> | _ -> - let largs = <:expr< Json.String $str:n$ >> :: List.map2 aux exprs args in - <:expr< Json.Array $expr_list_of_list _loc largs$ >> in + let largs = <:expr< `String $str:n$ >> :: List.map2 aux exprs args in + <:expr< `A $expr_list_of_list _loc largs$ >> in let patt = match k, args with | `N, [] -> <:patt< $uid:n$ >> | `P, [] -> <:patt< `$uid:n$ >> @@ -152,8 +152,8 @@ module Json_of = struct let pid, eid = new_id _loc () in <:expr< match $id$ with [ - None -> Json.Array [] - | Some $pid$ -> Json.Array [$aux eid o$] + None -> `A [] + | Some $pid$ -> `A [$aux eid o$] ] >> | Arrow _ -> failwith "arrow type is not supported" @@ -184,7 +184,7 @@ module Of_json = struct "Runtime error in '%s_of_json:%s': key '%s' not found in dictionary\\n" $str:name$ $str_of_id id$ $str:expected$; - raise (Json.Runtime_error ($str:expected$, Json.Null)) } + raise (Json.Runtime_error ($str:expected$, `Null)) } >> let runtime_error _loc name id expected = @@ -201,7 +201,7 @@ module Of_json = struct let t = match t_exp with Ext (_,t) | Rec (_,t) -> t | _ -> assert false in let rec aux id = function | Unit -> <:expr< match $id$ with [ - Json.Null -> () + `Null -> () | $runtime_error _loc n id "Null"$ ] >> | Int (Some i) when i + 1 = Sys.word_size -> @@ -224,7 +224,7 @@ module Of_json = struct | Int _ -> <:expr< match $id$ with [ - Json.String s -> Bigint.of_string s + `String s -> Bigint.of_string s | $runtime_error _loc n id "Int(int64)"$ ] >> | Float -> @@ -241,11 +241,11 @@ module Of_json = struct | $runtime_error _loc n id "Int(char)"$ ] >> | String -> <:expr< match $id$ with [ - Json.String x -> x + `String x -> x | $runtime_error _loc n id "String(string)"$ ] >> | Bool -> <:expr< match $id$ with [ - Json.Bool x -> x + `Bool x -> x | $runtime_error _loc n id "Bool"$ ] >> | Tuple t -> @@ -253,31 +253,31 @@ module Of_json = struct let patts,exprs = List.split ids in let exprs = List.map2 aux exprs t in <:expr< match $id$ with [ - Json.Array $patt_list_of_list _loc patts$ -> $expr_tuple_of_list _loc exprs$ + `A $patt_list_of_list _loc patts$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error _loc n id "Array"$ ] >> | List (Tuple [String; t]) -> (* XXX: handle the nested string case *) let pid, eid = new_id _loc () in <:expr< match $id$ with [ - Json.Object d -> List.map (fun (key, $pid$) -> (key, $aux eid t$)) d + `O d -> List.map (fun (key, $pid$) -> (key, $aux eid t$)) d | $runtime_error _loc n id "Object"$ ] >> | List t -> let pid, eid = new_id _loc () in <:expr< match $id$ with [ - Json.Array d -> List.map (fun $pid$ -> $aux eid t$) d + `A d -> List.map (fun $pid$ -> $aux eid t$) d | $runtime_error _loc n id "Array"$ ] >> | Array (Tuple [String; t]) -> (* XXX: handle the nested array case *) let pid, eid = new_id _loc () in <:expr< match $id$ with [ - Json.Object d -> Array.of_list (List.map (fun (key, $pid$) -> (key, $aux eid t$)) d) + `O d -> Array.of_list (List.map (fun (key, $pid$) -> (key, $aux eid t$)) d) | $runtime_error _loc n id "Object"$ ] >> | Array t -> let pid, eid = new_id _loc () in <:expr< match $id$ with [ - Json.Array d -> Array.of_list (List.map (fun $pid$ -> $aux eid t$) d) + `A d -> Array.of_list (List.map (fun $pid$ -> $aux eid t$) d) | $runtime_error _loc n id "Array"$ ] >> | Dict(`R, d) -> @@ -299,7 +299,7 @@ module Of_json = struct else $runtime_error_key_not_found _loc f id n$ >> in <:expr< match $id$ with [ - Json.Object $pid$ -> { $Ast.rbSem_of_list (List.map field d)$ } + `O $pid$ -> { $Ast.rbSem_of_list (List.map field d)$ } | $runtime_error _loc n id "Object"$ ] >> | Dict(`O, d) -> @@ -322,7 +322,7 @@ module Of_json = struct $runtime_error_key_not_found _loc f id n$ >> in <:expr< match $id$ with [ - Json.Object $pid$ -> object $Ast.crSem_of_list (List.map field d)$ end + `O $pid$ -> object $Ast.crSem_of_list (List.map field d)$ end | $runtime_error _loc n id "Object"$ ] >> | Sum (k, s) -> @@ -336,8 +336,8 @@ module Of_json = struct | `N, args -> List.fold_left (fun accu expr -> <:expr< $accu$ $expr$ >>) <:expr< $uid:n$ >> exprs | `P, args -> List.fold_left (fun accu expr -> <:expr< $accu$ $expr$ >>) <:expr< `$uid:n$ >> exprs in let patt = match args with - | [] -> <:patt< Json.String $str:n$ >> - | _ -> <:patt< Json.Array [ Json.String $str:n$ :: $patt_list_of_list _loc patts$ ] >> in + | [] -> <:patt< `String $str:n$ >> + | _ -> <:patt< `A [ `String $str:n$ :: $patt_list_of_list _loc patts$ ] >> in <:match_case< $patt$ -> $exprs$ >> in <:expr< match $id$ with [ $list:List.map mc s$ @@ -346,8 +346,8 @@ module Of_json = struct | Option t -> let pid, eid = new_id _loc () in <:expr< match $id$ with [ - Json.Array [] -> None - | Json.Array [ $pid$ ] -> Some $aux eid t$ + `A [] -> None + | `A [ $pid$ ] -> Some $aux eid t$ | $runtime_error _loc n id "Enum[]/Enum[_]"$ ] >> | Arrow _ -> failwith "arrow type is not yet supported" From 162cea159a7f6af6592d6f8630a83ccd7466bda3 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 05:39:38 -0800 Subject: [PATCH 6/7] put back Runtime_error exception undoing overzealous deletion --- lib/json.ml | 2 ++ lib/json.mli | 2 ++ 2 files changed, 4 insertions(+) diff --git a/lib/json.ml b/lib/json.ml index c2a487a..286cf3c 100644 --- a/lib/json.ml +++ b/lib/json.ml @@ -88,3 +88,5 @@ let to_buffer_hum t buf = let to_string_hum = Ezjsonm.to_string ~minify:false let of_string = Ezjsonm.from_string + +exception Runtime_error of string * t diff --git a/lib/json.mli b/lib/json.mli index 7c68b28..b0a3b2b 100644 --- a/lib/json.mli +++ b/lib/json.mli @@ -24,3 +24,5 @@ val to_buffer_hum : t -> Buffer.t -> unit val to_string_hum : t -> string val of_string : string -> t + +exception Runtime_error of string * t From 8a718abb23490e882f719e49e649fbd975b58ef1 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 25 Jan 2014 05:40:19 -0800 Subject: [PATCH 7/7] trickier int/float stuff --- syntax/json/extension.ml | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) diff --git a/syntax/json/extension.ml b/syntax/json/extension.ml index ee8b048..ae6dc06 100644 --- a/syntax/json/extension.ml +++ b/syntax/json/extension.ml @@ -75,20 +75,20 @@ module Json_of = struct let gen (_loc, n, t_exp) = let t = match t_exp with Ext (_,t) | Rec (_,t) -> t | _ -> assert false in let rec aux id = function - | Unit -> <:expr< Json.Null >> - | Bool -> <:expr< Json.Bool $id$ >> - | Float -> <:expr< Json.Float $id$ >> - | Char -> <:expr< Json.Int (Int64.of_int (Char.code $id$)) >> - | String -> <:expr< Json.String $id$ >> + | Unit -> <:expr< `Null >> + | Bool -> <:expr< `Bool $id$ >> + | Float -> <:expr< `Float $id$ >> + | Char -> <:expr< `Float (float_of_int (Char.code $id$)) >> + | String -> <:expr< `String $id$ >> | Int (Some i) when i + 1 = Sys.word_size -> - <:expr< Json.Int (Int64.of_int $id$) >> + <:expr< `Float (float_of_int $id$) >> | Int (Some i) when i <= 32 -> - <:expr< Json.Int (Int64.of_int32 $id$) >> + <:expr< `Float (float_of_int $id$) >> | Int (Some i) when i <= 64 -> - <:expr< Json.Int $id$ >> + <:expr< `Float (Int64.to_float $id$) >> | Int _ -> <:expr< `String (Bigint.to_string $id$) >> @@ -206,20 +206,20 @@ module Of_json = struct | Int (Some i) when i + 1 = Sys.word_size -> <:expr< match $id$ with [ - Json.Int x -> Int64.to_int x - | Json.String s -> int_of_string s + `Float x -> int_of_float x + | `String s -> int_of_string s | $runtime_error _loc n id "Int(int)"$ ] >> | Int (Some i) when i <= 32 -> <:expr< match $id$ with [ - Json.Int x -> Int64.to_int32 x - | Json.String s -> Int32.of_string s + `Float x -> Int32.of_float x + | `String s -> Int32.of_string s | $runtime_error _loc n id "Int(int32)"$ ] >> | Int (Some i) when i <= 64 -> <:expr< match $id$ with [ - Json.Int x -> x - | Json.String s -> Int64.of_string s + `Float x -> Int64.of_float x + | `String s -> Int64.of_string s | $runtime_error _loc n id "Int(int64)"$ ] >> | Int _ -> @@ -229,15 +229,14 @@ module Of_json = struct | Float -> <:expr< match $id$ with [ - Json.Float x -> x - | Json.Int x -> Int64.to_float x - | Json.String s -> float_of_string s + `Float x -> x + | `String s -> float_of_string s | $runtime_error _loc n id "Float"$ ] >> | Char -> <:expr< match $id$ with [ - Json.Int x -> Char.chr (Int64.to_int x) - | Json.String s -> Char.chr (int_of_string s) + `Float x -> Char.chr (int_of_float (x)) + | `String s -> Char.chr (int_of_string s) | $runtime_error _loc n id "Int(char)"$ ] >> | String -> <:expr< match $id$ with [