Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 6e99e9585a
Fetching contributors…

Cannot retrieve contributors at this time

file 155 lines (134 sloc) 4.511 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
(* Ohm is © 2012 Victor Nicollet *)

open BatPervasives

type t = Json_type.t =
  | Null
  | Array of t list
  | Object of (string * t) list
  | Float of float
  | Int of int
  | Bool of bool
  | String of string

exception Error = Json_type.Error

let of_json x = x
let to_json x = x

let of_string string =
  let lexbuf = Lexing.from_string string in
    try Json_lex.value lexbuf
    with _ -> let s = String.sub
lexbuf.Lexing.lex_buffer
lexbuf.Lexing.lex_start_pos
(String.length lexbuf.Lexing.lex_buffer - lexbuf.Lexing.lex_start_pos)
in
raise (Json_lex.unexpected s)

let to_string json =
  let buffer = Buffer.create 1024 in
  let rec value = function
    | Json_type.String s -> string s
    | Json_type.Null -> Buffer.add_string buffer "null"
    | Json_type.Bool true -> Buffer.add_string buffer "true"
    | Json_type.Bool false -> Buffer.add_string buffer "false"
    | Json_type.Int i -> Buffer.add_string buffer (string_of_int i)
    | Json_type.Float f -> let f = string_of_float f in
if f.[String.length f - 1] = '.' then
Buffer.add_substring buffer f 0 (String.length f - 1)
else
Buffer.add_string buffer f
    | Json_type.Array [] -> Buffer.add_string buffer "[]"
    | Json_type.Object [] -> Buffer.add_string buffer "{}"

    | Json_type.Array (h :: t) ->
      Buffer.add_char buffer '[' ;
      value h ;
      List.iter (fun x -> Buffer.add_char buffer ',' ; value x) t ;
      Buffer.add_char buffer ']'

    | Json_type.Object (h :: t) ->
      Buffer.add_char buffer '{' ;
      pair h ;
      List.iter (fun x -> Buffer.add_char buffer ',' ; pair x) t ;
      Buffer.add_char buffer '}'
  and pair (k,v) =
    string k ;
    Buffer.add_char buffer ':' ;
    value v
  and string s =
    Buffer.add_char buffer '"' ;
    clean s 0 0 (String.length s);
    Buffer.add_char buffer '"'
  and clean s prev n m =
    if m = n then
      if prev < n then Buffer.add_substring buffer s prev (n-prev) else ()
    else
      match s.[n] with
| '\"' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\\"" ;
clean s (n+1) (n+1) m
| '\n' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\n" ;
clean s (n+1) (n+1) m
| '\b' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\b" ;
clean s (n+1) (n+1) m
| '\t' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\t" ;
clean s (n+1) (n+1) m
| '\r' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\r" ;
clean s (n+1) (n+1) m
| '\\' ->
if prev < n then Buffer.add_substring buffer s prev (n-prev) ;
Buffer.add_string buffer "\\\\" ;
clean s (n+1) (n+1) m
| _ -> clean s prev (n+1) m
  in
  
  value json ;
  Buffer.contents buffer
     
let of_assoc list = Object list
let of_int int = Int int
let of_float float = Float float
let of_string string = String string
let of_bool bool = Bool bool
let of_array list = Array list
let of_opt f x = BatOption.default Null (BatOption.map f x)
let of_list f list = Array (List.map f list)

let parse_error what json =
  let string = to_string json in
  raise (Error (Printf.sprintf "Expected %s, found `%s`" what string))

let to_object f = function
  | Object list -> let opt s = try Some (List.assoc s list) with Not_found -> None in
let req s = try List.assoc s list with Not_found ->
parse_error ("object with key `" ^ s ^ "`") (Object list) in
f ~opt ~req
  | json -> parse_error "object" json

let to_list f = function
  | Array list -> List.map f list
  | json -> parse_error "array" json

let to_int = function
  | Int i -> i
  | json -> parse_error "int" json

let to_float = function
  | Float f -> f
  | Int i -> float_of_int i
  | json -> parse_error "float" json

let to_string = function
  | String s -> s
  | json -> parse_error "string" json

let to_bool = function
  | Bool b -> b
  | json -> parse_error "bool" json

let to_opt f = function
  | Null -> None
  | json -> Some (f json)
 
let parse f json =
  try Ok (f json) with
    | Error e -> Bad (Error (e ^ " in " ^ to_string json))
    | exn -> Bad exn

let to_array = function
  | Array a -> a
  | json -> parse_error "array" json

let to_assoc = function
  | Object o -> o
  | json -> parse_error "object" json
Something went wrong with that request. Please try again.