Source

raytracer / json.ml

(* a JSON parser using parsing combinators *)

module type Json_t =
sig
  type json
  val dumps : json -> String.t
  (*val dump : json -> out_channel*)
  val loads : String.t -> json
  (*val load : in_channel -> json*)
  val lookup : json -> json -> json
  val option_lookup : json -> json -> json option
  val chain_lookup : json list -> json -> json
  val chain_option_lookup : json list -> json -> json option
  val force_int : json -> int
  val force_string : json -> string
  val force_float : json -> float
  val force_bool : json -> bool
  exception Lookup_error of string
end

module Json : Json_t =
struct

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

exception Lookup_error of string
exception Json_type_error

let force_int = function Int i -> i | _ -> raise Json_type_error
let force_string = function String s -> s | _ -> raise Json_type_error
let force_float = function Float f -> f | Int i -> (float_of_int i)
  | _ -> raise Json_type_error
let force_bool = function True -> true | False -> false
  | _ -> raise Json_type_error

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

let dumps (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 option_lookup (key:json) (value:json) : json option =
  match (key,value) with
    | (Int i, Array l) -> (
	if i < List.length l && i >= 0 then Some (List.nth l i) else None)
    | (String s, Dict d) -> (
	if StringMap.mem s d then Some (StringMap.find s d) else None)
    | _ -> None

let lookup (key:json) (value:json) : json =
  match option_lookup key value with
    | Some result -> result
    | None -> raise (Lookup_error (dumps key))

let chain_lookup (keys:json list) (value:json) : json =
  List.fold_left (fun a b -> lookup b a) value keys

let rec chain_option_lookup k v =
  match k with
    | [] -> Some v
    | hd::rest -> (
	match option_lookup hd v with
	  | Some result -> chain_option_lookup rest result
	  | None -> None)

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)
    		 
(* 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] 

let assert_success (pr:'a parse_result) : unit =
  match pr with
    | Failure -> assert false
    | Success _ -> ()

(* 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_digit =
  parse_any_char ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']

let parse_int =
  parse_compose (compose int_of_string implode) (parse_plus parse_digit)

let parse_float =
  let dot = parse_compose listify (parse_char '.') in
  parse_compose (compose float_of_string implode) (
    parse_combine [parse_plus parse_digit; dot; parse_kleene_star 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 parse_json_float = parse_compose (fun f -> Float f ) parse_float

let parse_delimited (start:char) (last:char) (delim:char) p =
  let parse_delim = parse_char delim in
    parse_combine [
      parse_ignore (parse_char start);
      parse_kleene_star (
	parse_compose (fun l -> List.nth l 0)
	  (parse_combine [parse_compose listify p;
			  parse_ignore parse_delim]));
      parse_optional p;
      parse_ignore (parse_char last)]

let rec parse_json_list cs = 
  let l = parse_delimited '[' ']' ',' parse_json in
    parse_compose (fun l -> Array l) l cs
and parse_json_array cs =
  let extract_pair p =
    let k = 
      match List.nth p 0 with
	| String s -> s 
	| _ -> raise (Invalid_argument "extract_pair")
    in
      (k, List.nth p 1)
  in
  let parse_pair = 
    parse_compose extract_pair (
      parse_combine [
	parse_compose listify parse_json_string;
	parse_ignore parse_wc;
	parse_ignore (parse_char ':');
	parse_ignore parse_wc;
	parse_compose listify parse_json])
  in
    parse_compose build_dict (parse_delimited '{' '}' ',' parse_pair) 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_float;
		   parse_json_int;
		   parse_json_list;
		   parse_json_array]); 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 (s:string) : json =
  match parse_json (explode s) with
    | Failure -> raise Json_parse_error
    | Success (result,rest) -> (
	match rest with
	  | [] -> result
	  | _ -> raise Json_parse_error)

(*
let parse_test =
  let s = 
    "[true,false,null,\"hello\", 1   , 
     2.05 ,  {\"abc\":[1,2,[3 ]  ]}]   "
  in
    print_endline (dumps (loads s))

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 (dumps js)    
*)
end