{
mutable cursor: cursor;
mutable stack: int_value list;
- mutable num_chars_parsed: int
+ mutable num_chars_parsed: int;
+ mutable line_num: int
}
let init_parse_state () =
{
cursor = Start;
stack = [];
- num_chars_parsed = 0
+ num_chars_parsed = 0;
+ line_num = 1
}
let is_parsing_object s =
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
iter 0 cs;
s
-exception Unexpected_char of char * (* json type *) string
-exception Invalid_value of (* value *) string * (* json type *) string
-exception Invalid_leading_zero of string
-exception Unterminated_value of string
-exception Internal_error of string
+exception Unexpected_char of int * char * (* json type *) string
+exception Invalid_value of int * (* value *) string * (* json type *) string
+exception Invalid_leading_zero of int * string
+exception Unterminated_value of int * string
+exception Internal_error of int * string
+
+let raise_unexpected_char s c t =
+ raise (Unexpected_char (s.line_num, c, t))
+let raise_invalid_value s v t =
+ raise (Invalid_value (s.line_num, v, t))
+let raise_invalid_leading_zero s n =
+ raise (Invalid_leading_zero (s.line_num, n))
+let raise_unterminated_value s v =
+ raise (Unterminated_value (s.line_num, v))
+let raise_internal_error s m =
+ raise (Internal_error (s.line_num, m))
let finish_value s v =
match s.stack, v with
s.stack <- IArray (v :: l) :: tl;
s.cursor <- Expect_comma_or_end
| io :: tl, _ ->
- raise (Internal_error ("unexpected " ^ (ivalue_to_str io)
- ^ " on stack at finish_value"))
+ raise_internal_error s ("unexpected " ^ (ivalue_to_str io)
+ ^ " on stack at finish_value")
let pop_stack s =
match s.stack with
s.stack <- tl;
finish_value s (Json.Json_array (Array.of_list (List.rev l)))
| io :: tl ->
- raise (Internal_error ("unexpected " ^ (ivalue_to_str io)
- ^ " on stack at pop_stack"))
+ raise_internal_error s ("unexpected " ^ (ivalue_to_str io)
+ ^ " on stack at pop_stack")
| [] ->
- raise (Internal_error "empty stack at pop_stack")
+ raise_internal_error s "empty stack at pop_stack"
let rec parse_char s c =
- (* Printf.printf "parsing %C at %s...\n" c (current_cursor_value s.cursor); *)
+ (* 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 (clist_to_string ris))
+ 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 (str, "int")) in
+ with Failure _ -> raise_invalid_value s str "int" in
finish_value s (Json.Json_int int) in
let finish_int_exp is es =
let int = tostring_with_leading_zero_check is in
succeed in making this an int, but
returning float is more uniform. *)
let float = try float_of_string str
- with Failure _ -> raise (Invalid_value (str, "float")) in
+ with Failure _ -> raise_invalid_value s str "float" in
finish_value s (Json.Json_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 (str, "float")) in
+ with Failure _ -> raise_invalid_value s str "float" in
finish_value s (Json.Json_float float) in
let finish_float_exp is fs es =
let int = tostring_with_leading_zero_check is 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 (str, "float")) in
+ with Failure _ -> raise_invalid_value s str "float" in
finish_value s (Json.Json_float float) in
match s.cursor with
| ']' when s.stack <> [] ->
pop_stack s
| _ when is_space c ->
- ()
+ update_line_num s c
| _ ->
- raise (Unexpected_char (c, "start")))
+ raise_unexpected_char s c "start")
| Expect_value ->
(match c with
| 'n' ->
s.stack <- (IArray []) :: s.stack;
s.cursor <- Start
| _ when is_space c ->
- ()
+ update_line_num s c
| _ ->
- raise (Unexpected_char (c, "value")))
+ raise_unexpected_char s c "value")
| In_null rem ->
(match c, rem with
| 'u', 3 ->
| 'l', 1 ->
finish_value s Json.Json_null
| _ ->
- raise (Unexpected_char (c, "null")))
+ raise_unexpected_char s c "null")
| In_true rem ->
(match c, rem with
| 'r', 3 ->
| 'e', 1 ->
finish_value s (Json.Json_bool true)
| _ ->
- raise (Unexpected_char (c, "true")))
+ raise_unexpected_char s c "true")
| In_false rem ->
(match c, rem with
| 'a', 4 ->
| 'e', 1 ->
finish_value s (Json.Json_bool false)
| _ ->
- raise (Unexpected_char (c, "false")))
+ raise_unexpected_char s c "false")
| In_int is ->
(match c with
| '0' .. '9' ->
finish_int is;
parse_char s c
| _ when is_space c ->
+ update_line_num s c;
finish_int is
| _ ->
- raise (Unexpected_char (c, "int")))
+ raise_unexpected_char s c "int")
| In_float (is, fs) ->
(match c with
| '0' .. '9' ->
finish_float is fs;
parse_char s c
| _ when is_space c ->
+ update_line_num s c;
finish_float is fs
| _ ->
- raise (Unexpected_char (c, "float")))
+ raise_unexpected_char s c "float")
| In_int_exp (is, es) ->
(match c with
| '+' | '-' | '0' .. '9' ->
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 (c, "int_exp")))
+ raise_unexpected_char s c "int_exp")
| In_float_exp (is, fs, es) ->
(match c with
| '+' | '-' | '0' .. '9' ->
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 (c, "float_exp")))
+ raise_unexpected_char s c "float_exp")
| In_string cs ->
(match c with
| '\\' ->
finish_value s (Json.Json_string (clist_to_string (List.rev cs)))
| _ ->
if is_valid_unescaped_char c then s.cursor <- In_string (c :: cs)
- else raise (Unexpected_char (c, "string")))
+ else raise_unexpected_char s c "string")
| In_string_control cs ->
(match c with
| '"' | '\\' | '/' ->
| 'u' ->
s.cursor <- In_string_hex (cs, [], 4)
| _ ->
- raise (Unexpected_char (c, "string_control")))
+ 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
(* TODO: We currently just leave the unicode escapes in place. *)
s.cursor <- In_string (hs @ ('u' :: '\\' :: cs))
end else
- raise (Unexpected_char (c, "string_unicode")))
+ raise_unexpected_char s c "string_unicode")
| Expect_object_elem_start ->
(match c with
| '"' ->
| '}' ->
finish_value s (Json.Json_object (Array.of_list []))
| _ when is_space c ->
- ()
+ update_line_num s c
| _ ->
- raise (Unexpected_char (c, "object_start")))
+ 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 (c, "object_elem_colon")))
+ raise_unexpected_char s c "object_elem_colon")
| Expect_comma_or_end ->
(match c with
| ',' ->
else s.cursor <- Expect_value
| '}' ->
if is_parsing_object s then pop_stack s
- else raise (Unexpected_char (c, "comma_or_end"))
+ else raise_unexpected_char s c "comma_or_end"
| ']' ->
if not (is_parsing_object s) then pop_stack s
- else raise (Unexpected_char (c, "comma_or_end"))
+ else raise_unexpected_char s c "comma_or_end"
| _ when is_space c ->
- ()
+ update_line_num s c
| _ ->
- raise (Unexpected_char (c, "comma_or_end")))
+ 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 ("unexpected " ^ (ivalue_to_str io) ^ " on stack at object_key"))
- | [] -> raise (Internal_error ("empty stack at object_key")));
+ | 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 (c, "object_key")))
+ raise_unexpected_char s c "object_key")
| Done _ ->
- raise (Internal_error "parse called when parse_state is 'Done'")
+ raise_internal_error s "parse called when parse_state is 'Done'"
type parse_result =
| Json_value (v, _) -> Some v
| Json_parse_incomplete _ ->
if state.cursor = Start then None
- else raise (Unterminated_value (current_cursor_value state.cursor))
+ else raise_unterminated_value state (current_cursor_value state.cursor)
let num_chars_parsed state = state.num_chars_parsed
projects / xenclient / toolstack.git / commitdiff