Commits

Jeremy Hoon  committed 0749b1e

generally working json parser, without objects

  • Participants
  • Parent commits 3a89de9

Comments (0)

Files changed (1)

     Dict (List.fold_left add StringMap.empty pairs)
 
 let dump (json:json) =
+  let stringify s = "\"" ^ s ^ "\"" in
   let rec down ret = function
     | True -> "true"::ret
     | False -> "false"::ret
     | Null -> "null"::ret
-    | String s -> ("\"" ^ s ^ "\"")::ret
+    | String s -> (stringify s)::ret
     | Int i -> (string_of_int i)::ret
     | Float f -> (string_of_float f)::ret
     | Array l -> (
 	let aggregate k v acc = (k,v)::acc in
 	let pairs = StringMap.fold aggregate d [] in
 	let rec loop ret = function
-	  | (k,v)::[] -> "}"::(down (": "::k::ret) v)
-	  | (k,v)::rest -> loop (", "::(down (": "::k::ret) v)) rest
+	  | (k,v)::[] -> "}"::(down (": "::(stringify k)::ret) v)
+	  | (k,v)::rest -> loop (", "::(down (": "::(stringify k)::ret) v)) rest
 	  | [] -> ["}"]
 	in
 	  loop ("{"::ret) pairs)
     assert ((json_compare result (Int 1)) = 0);
     print_endline (dump js)
 
+(* parsing combinators *)
+
+type 'a parse_result = Failure | Success of 'a * (char list)
+type 'a parse_fun = char list -> 'a parse_result
+
+(* parsing utils *)
+
+let explode (s:string) : char list =
+  let rec loop ret i =
+    match i with
+      | -1 -> ret
+      | _ -> loop ((String.get s i)::ret) (i-1)
+  in
+    loop [] ((String.length s) - 1)
+
+let implode (cs: char list) : string =
+  let ss = List.map (fun c -> String.make 1 c) cs in
+    String.concat "" ss
+
+let compose f g = fun x -> f (g x)
+let listify x = [x] 
+
+(* primitive combinators *)
+ 
+let parse_pred (fn: char -> bool) : char parse_fun =
+  let parse (cs:char list) : char parse_result =
+    match cs with
+      | hd::rest -> if fn hd then Success (hd,rest) else Failure
+      | _ -> Failure
+  in
+    parse
+
+let parse_char (c:char) : char parse_fun = parse_pred (fun c2 -> c = c2)
+
+let parse_compose (fn: 'a -> 'b) (p: 'a parse_fun) : 'b parse_fun =
+  let parse cs =
+    match p cs with
+      | Failure -> Failure
+      | Success (result,rest) -> Success (fn result,rest)
+  in
+    parse
+
+let parse_all (ps:'a parse_fun list) : 'a list parse_fun =
+  let parse (cs:char list)  =
+    let rec down ret rem_cs = function
+      | [] -> Success (List.rev ret, rem_cs)
+      | p::rest -> (
+	    match p rem_cs with
+	      | Failure -> Failure
+	      | Success (result,rest_cs) -> down (result::ret) rest_cs rest)
+    in
+      down [] cs ps
+  in
+    parse
+
+let parse_first (ps:'a parse_fun list) : 'a parse_fun =
+  let parse (cs:char list) : 'a parse_result =
+    let rec down = function
+      | [] -> Failure
+      | p::rest -> (
+	  let result = p cs in
+	  match result with
+	    | Failure -> down rest
+	    | Success _ -> result)
+    in
+      down ps
+  in
+    parse
+
+let parse_map (f:'a -> 'b) (p: 'a list parse_fun) : 'b list parse_fun =
+  let parse (cs:char list) =
+    match p cs with
+      | Failure -> Failure
+      | Success (result,rest) -> Success (List.map f result, rest)
+  in
+    parse
+
+let parse_any_char (cs:char list) : char parse_fun =
+  let choices = List.map parse_char cs in
+    parse_first choices
+
+let parse_exclude_chars (cs:char list) : char parse_fun =
+  let pred c = not (List.exists (fun c2 -> c = c2) cs) in
+    parse_pred pred
+
+let parse_combine (ps: 'a list parse_fun list) : 'a list parse_fun =
+  let parse cs =
+    match parse_all ps cs with
+      | Failure -> Failure
+      | Success (results,rest) -> Success (List.flatten results, rest)
+  in
+    parse
+
+let parse_string (s:string) : char list parse_fun =
+  let all = List.map parse_char (explode s) in
+    parse_all all
+
+let parse_kleene_star (p:'a parse_fun) : 'a list parse_fun =
+  let parse (cs:char list) : 'a list parse_result =
+    let rec down ret rem_cs =
+      match p rem_cs with
+	| Failure -> Success (List.rev ret, rem_cs)
+	| Success (result,rest) -> down (result::ret) rest
+    in
+      down [] cs
+  in
+    parse
+
+let parse_plus (p:'a parse_fun) : 'a list parse_fun =
+    parse_combine [parse_compose listify p; parse_kleene_star p]
+
+let parse_optional (p: 'a parse_fun) : 'a list parse_fun =
+  let parse cs =
+    let result = p cs in
+    match result with
+      | Failure -> Success ([],cs)
+      | Success (result,rest) -> Success ([result],rest)
+  in
+    parse
+
+(* specific JSON combinators *)
+
+let parse_string = 
+  let quote = '"' in
+  let parse_quote = parse_compose listify (parse_char quote) in
+  let triple = 
+    parse_all [parse_quote; parse_kleene_star (parse_exclude_chars [quote]);
+	       parse_quote]
+  in
+  let extract result = implode (List.nth result 1) in
+    parse_compose extract triple
+
+let parse_int =
+  let parse_digit =
+    parse_any_char ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']
+  in
+  parse_compose (compose int_of_string implode) (parse_plus parse_digit)
+
+let parse_word w = parse_all (List.map parse_char (explode w))
+let parse_wc = 
+  let wc = parse_any_char (explode " \t\r\n") in
+    parse_compose (fun x -> []) (parse_kleene_star wc)
+let parse_ignore p =
+  parse_compose (fun x -> []) p
+
+let parse_json_true = parse_compose (fun x -> True) (parse_word "true")
+let parse_json_false = parse_compose (fun x -> False) (parse_word "false")
+let parse_json_null = parse_compose (fun x -> Null) (parse_word "null")
+let parse_json_string = parse_compose (fun s -> String s) parse_string
+let parse_json_int = parse_compose (fun i -> Int i) parse_int
+let rec parse_json_list cs = 
+  let parse_comma = parse_char ',' in
+  let l : json list parse_fun = 
+    parse_combine [
+      parse_ignore (parse_char '[');
+      parse_kleene_star (
+	parse_compose (fun (l:json list) -> List.nth l 0)
+	  (parse_combine [parse_compose listify parse_json;
+			  parse_ignore parse_comma]));
+      parse_optional parse_json;
+      parse_ignore (parse_char ']')]
+  in
+    parse_compose (fun l -> Array l) l cs
+and parse_json cs : json parse_result =
+  parse_compose (fun x -> List.nth x 0)
+    (parse_combine [parse_wc; parse_compose listify (parse_first [
+		   parse_json_true;
+		   parse_json_false;
+		   parse_json_null;
+		   parse_json_string;
+		   parse_json_int;
+		   parse_json_list]); parse_wc]) cs
+
+let quick_print (pr:'a parse_result) : unit =
+  print_endline (match pr with
+		   | Failure -> "Failure"
+		   | Success _ -> "Success")
+
+let parse_test = 
+  let s = "\"hello\"" in
+  let string_result = parse_string (explode s) in
+  let int_result = parse_int (explode "100") in
+    (match string_result with
+      | Failure -> assert false
+      | Success (result,rest) -> assert (String.compare result "hello" = 0));
+    (match int_result with
+       | Failure -> assert false
+       | Success (result,rest) -> assert (result = 100))
+
+exception Json_parse_error
+
+let loads_json (s:string) : json =
+  match parse_json (explode s) with
+    | Failure -> raise Json_parse_error
+    | Success (result,rest) -> result
+
+let test =
+  print_endline (dump (loads_json "[true,false,1,    2, 256]"));
+
+    
+  
+    
+
+