Source

raytracer / json.ml

(* a JSON parser using parsing combinators *)

module StringMap = Map.Make(struct 
			      type t = String.t 
			      let compare = String.compare 
			    end)
type json = String of string | Int of int | Float of float
	    | Dict of json StringMap.t | Array of json list
	    | True | False | Null
	    
and jsonmap = (json * json) list

let rec mergesort (cmp: 'a -> 'a -> int) (l: 'a list) : 'a list = []

let rec json_compare (js1:json) (js2:json) : int =
  let compare_maps = StringMap.compare json_compare in
  let rec compare_lists l1 l2 =
    match (l1,l2) with
      | (hd1::rest1,hd2::rest2) -> (
	  let cmp_result = json_compare hd1 hd2 in
	    if cmp_result = 0 then compare_lists rest1 rest2 else cmp_result)
      | ([],[]) -> 0
      | _ -> (List.length l1) - (List.length l2)
  in
  let rank = function
    | String _ -> 0
    | Int _ -> 1
    | Float _ -> 2
    | Dict _ -> 3
    | Array _ -> 4
    | True _ -> 5
    | False _ -> 6
    | Null _ -> 7
  in
  match (js1,js2) with
    | (String s1, String s2) -> String.compare s1 s2
    | (Int i1, Int i2) -> i1 - i2
    | (Float f1, Float f2) -> (
	if f1 > f2 then 
	  1
	else (
	  if f1 = f2 then 0 else -1))
    | (Dict d1, Dict d2) -> compare_maps d1 d2
    | (Array l1, Array l2) -> compare_lists l1 l2
    | _ -> (rank js1) - (rank js2)

let json_sort = mergesort json_compare

exception Lookup_error of string

let lookup (key:json) (value:json) =
  match (key,value) with
    | (Int i, Array l) -> List.nth l i
    | (String s, Dict d) -> StringMap.find s d
    | _ -> raise (Lookup_error "Invalid lookup type")

let build_dict (pairs: (String.t * json) list) : json =
  let add acc (k,v) = StringMap.add k v acc in
    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 -> (stringify s)::ret
    | Int i -> (string_of_int i)::ret
    | Float f -> (string_of_float f)::ret
    | Array l -> (
	let rec loop ret = function
	  | hd::[] -> "]"::(down ret hd)
	  | hd::rest -> loop (", "::(down ret hd)) rest
	  | [] -> ["]"]
	in
	  loop ("["::ret) l)
    | Dict d -> (
	let aggregate k v acc = (k,v)::acc in
	let pairs = StringMap.fold aggregate d [] in
	let rec loop ret = function
	  | (k,v)::[] -> "}"::(down (": "::(stringify k)::ret) v)
	  | (k,v)::rest -> loop (", "::(down (": "::(stringify k)::ret) v)) rest
	  | [] -> ["}"]
	in
	  loop ("{"::ret) pairs)
  in
  let strs = down [] json in
    String.concat "" (List.rev strs)
    		 
let lookup_test = 
  let pairs = [("red",Int 0); ("green",Int 1);
	       ("blue",Array [String "hello"; String "goodbye"])] in
  let js = build_dict pairs in
  let query = String "green" in
  let result = lookup query js in
    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]"));