Source

raytracer / json.ml

Full commit
(* 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 rec down ret = function
    | True -> "true"::ret
    | False -> "false"::ret
    | Null -> "null"::ret
    | String s -> ("\"" ^ 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 (": "::k::ret) v)
	  | (k,v)::rest -> loop (", "::(down (": "::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)