json-static-0.9.8/0000775000375200037520000000000011247725620013354 5ustar martinmartinjson-static-0.9.8/Camlp4Version0000644000375200037520000000166211247725620015770 0ustar martinmartinifndef CAMLP4_VERSION CAMLP4_VERSION = \ $(shell if `which camlp4orf 2>/dev/null`; then echo 310; else echo 309; fi) endif export CAMLP4_VERSION ifndef CAMLP4ORF ifeq ($(CAMLP4_VERSION),309) CAMLP4ORF = camlp4o pa_extend.cmo q_MLast.cmo else CAMLP4ORF = camlp4orf endif endif export CAMLP4ORF ifndef CAMLP4RF ifeq ($(CAMLP4_VERSION),309) CAMLP4RF = camlp4r pa_extend.cmo q_MLast.cmo else CAMLP4RF = camlp4rf endif endif export CAMLP4RF ifndef PR_O ifeq ($(CAMLP4_VERSION),309) PR_O = pr_o.cmo else PR_O = -printer o endif endif export PR_O ifndef PR_R ifeq ($(CAMLP4_VERSION),309) PR_R = pr_r.cmo else PR_R = -printer r endif endif export PR_R ifndef PARSER ifeq ($(CAMLP4_VERSION),309) PARSER = else PARSER = -parser endif endif export PARSER ifndef PRINTER ifeq ($(CAMLP4_VERSION),309) PRINTER = else PRINTER = -printer endif endif export PRINTER json-static-0.9.8/LICENSE0000644000375200037520000000261111247725620014357 0ustar martinmartinCopyright (c) 2007 Burnham Institute for Medical Research All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. json-static-0.9.8/README0000644000375200037520000002002711247725620014233 0ustar martinmartin json-static Introduction ============ json-static is a syntax extension of OCaml that can make the use of JSON data easier. From a special type declaration, the camlp4 preprocessor generates the code that converts between a JSON "abstract syntax tree" and specialized OCaml data structures such as objects, polymorphic variants, lists, arrays, tuples, etc. It will at the same time check that the structure of the JSON document is correct and produce OCaml data which is statically typed. For example, the following declaration defines the type of a point object: type json point = < x: float; y: float > This automatically makes two functions available, with the following signature: val json_of_point : point -> Json_type.t val point_of_json : Json_type.t -> point Json_type.t is the type of parsed JSON data, which is provided by the json-wheel library. Function json_of_point would convert an OCaml object of type point into a JSON object. point_of_json works the other way around, and fails by raising the Json_type.Json_error exception if the input JSON data doesn't have the right format. Installation ============ Installation: make make install Uninstallation: make uninstall Usage ===== Basically, you must preprocess your OCaml file(s) with camlp4o pa_json_static.cmo. Once installed using the standard procedure (ocamlfind), you can compile a file using these commands: # compile ocamlfind ocamlopt -c yourfile.ml -syntax camlp4o -package json-static # link ocamlfind ocamlopt -o yourprog yourfile.cmx -linkpkg -package json-wheel Build tools like OCamlMakefile take care of this nicely. Syntax ====== You must write a special type declaration that describes the expected format of the JSON data. There is a predefined mapping from OCaml types to JSON: OCaml type JSON type Properties of JSON data ---------- --------- ----------------------- string String float Number not an int int Number an int number* Number a float or an int bool Boolean list Array homogenous array Array homogenous tuple Array fixed length (string * 'a) assoc** Object an object read as an associative list (string, 'a) Hashtbl.t Object object or record Object additional methods/fields are ignored option any null means None polymorphic variants String or Array a String for constructors without an argument, or an Array of length 2 where the first element is a String that represents the constructor and the second element is the argument. classic variants String or Array a String for contructors without an argument, or an Array where the first element is the String that represents the constructor and the rest are the arguments. Unlike polymorphic variants, there may be several arguments (just don't use parentheses around them in the type definition). X.t*** defined by X.of_json and X.to_json --- *: the number type is an alias for float, but accepts JSON ints and converts them to OCaml floats. **: the assoc type is an alias for list, but converts from a JSON object. ***: X can be any simple module name, but module fields t, of_json and to_json are mandatory. A type definition is done like regular type definitions, but the keyword "json" is placed just after "type", as in: type json t = int * float ^^^^ The type cannot be polymorphic, i.e. it doesn't support type parameters. A small set of basic types are supported (see table above). Other type names can be used only if they are part of the same definition. This works: type json a = b and b = int list But the following doesn't work: type json b = int list type json a = b (* b is unknown to the preprocessor *) In addition to the basic syntax for type declarations, a few extensions have been added: 1) Object labels or variant names can be followed by an arbitrary string. When it is the case, this defines the string to be found in the JSON data. 2) Object methods can be preceded by a questionmark. If it is the case, JSON objects that do not have this field could still be read. Their value is set to null instead of being undefined and causing an error. 3) A default value can be specified a after a method definition. The syntax is a "=" followed by an expression. The expression should be a constant. The default expression is used whenever the JSON null value is encountered, even if the type converter knows how to deal with null. 4) Records and variant types must be named, as always in OCaml. Reusing an existing definition is possible by using the "predefined" keyword as in type point = predefined { x : float; y : float } or type t = predefined A | B of bool * t Predefined read-only records or variant types (private) cannot be used as of version 0.9.3 of this program. A common use of optional methods without a default argument is when omitting an object field is allowed and considered equivalent to a null value. Optional methods of a type that doesn't accept the null value don't make much sense but are not rejected. The following is most likely an error: type json point = < ?x : int > (if field "x" is not found in the JSON object, then the error would be that null is not a valid int, instead of saying that field "x" is missing) It should be either type json point = < ?x : int option > or type json point = < ?x : int = 0 > Example 1 ========= The following definition is correct: type json point = < x: number; y: number > and coords = point array It can load successfully the following JSON data: [ { "x": 1, "y": 0.5 }, { "x": 0, "y": 0.3333333 } ] Full example: (* File example1.ml *) type json point = < x: number; y: number > and coords = point array let json_string = " [ { \"x\": 1, \"y\": 0.5 }, { \"x\": 0, \"y\": 0.3333333 } ] " let json_tree = Json_io.json_of_string json_string let my_coords = coords_of_json json_tree let _ = Array.iter (fun p -> Printf.printf "(%g, %g)\n" p#x p#y) my_coords (* EOF *) Save the example as "example1.ml", compile it and run it: $ ocamlfind ocamlopt -o example1 -linkpkg -package json-static -syntax camlp4o example1.ml $ ./example1 (1, 0.5) (0, 0.333333) Example 2 ========= This example shows you the representation that we chose for sum types in JSON: (* File example2.ml *) type json colors = [ `Black | `White | `Rgb of (float * float * float) | `Any "*" ] list let my_colors = [ `Black; `White; `Any; `Rgb (1., 0., 0.); `Rgb (0., 1., 0.); `Rgb (0., 0., 1.) ] let _ = print_endline (Json_io.string_of_json (json_of_colors my_colors)) (* EOF *) $ ocamlfind ocamlopt -o example2 -linkpkg -package json-static -syntax camlp4o example2.ml $ ./example2 [ "Black", "White", "*", [ "Rgb", [ 1.0, 0.0, 0.0 ] ], [ "Rgb", [ 0.0, 1.0, 0.0 ] ], [ "Rgb", [ 0.0, 0.0, 1.0 ] ] ] Note how we specified that `Any translates into "*" rather than "Any". The same technique is available to rename object methods, and it is crucial when some existing JSON format uses method names that are not valid OCaml identifiers. json-static-0.9.8/pa_json_static.ml.3090000644000375200037520000006505511247725620017231 0ustar martinmartin(* Conversion between OCaml types and JSON types as provided by the json-wheel library. Author: Martin Jambon Copyright (c) 2007 Burnham Institute for Medical Research Copyright (c) 2007 Wink Technologies Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) open Printf let light_mode = ref false let reserved_prefix = "__json_static_" let new_id = let n = ref 0 in fun name -> incr n; reserved_prefix ^ name ^ string_of_int !n let check_unique f l = let tbl = Hashtbl.create 50 in List.iter (fun x -> let (_loc, id) = f x in if Hashtbl.mem tbl id then Stdpp.raise_with_loc _loc (Failure "this tag or label is not unique") else Hashtbl.add tbl id ()) l let unopt default = function None -> default | Some x -> x let rec optmap f = function [] -> [] | hd :: tl -> match f hd with None -> optmap f tl | Some x -> x :: optmap f tl type field = { field_caml_name : string; field_json_name : string; field_type : t; field_caml_loc : Token.flocation; field_json_loc : Token.flocation; optional : bool; default : MLast.expr option; subset : subset option; validator_name : string option; is_mutable : bool } and subset = [ `List of MLast.expr | `Dynlist of MLast.expr | `Abstract_set of MLast.expr ] and constructor = { cons_caml_name : string; cons_json_name : string; cons_args : t list; cons_caml_loc : Token.flocation; cons_json_loc : Token.flocation } and type_expr = List of t | Array of t | Option of t | Object of field list | Record of field list | Hashtbl of t | Assoc of t | Tuple of t list | Variant of constructor list | Poly of constructor list | Name of string | String | Bool | Int | Float | Number | Raw | Custom of string and t = Token.flocation * type_expr and typedef = { def : t; is_predefined : bool; is_private : bool (* unused at the moment *) } module StringMap = Map.Make (String) let error _loc = <:str_item< value __json_static_error obj msg = let m = 400 in let s = Json_io.string_of_json obj in let obj_string = if String.length s > m then String.sub s 0 (m - 4) ^ " ..." else s in Json_type.json_error (msg ^ ":\n" ^ obj_string) >> let numbered_list l = Array.to_list (Array.mapi (fun i x -> (x, "x" ^ string_of_int i)) (Array.of_list l)) let eta_expand = function (<:expr< fun [ $list:_$ ] >>) as f -> f | e -> let _loc = MLast.loc_of_expr e in (<:expr< fun x -> $e$ x >>) let make_ofjson_defs _loc l = let browse _loc f = <:expr< Json_type.Browse.$lid:f$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< $browse _loc "list"$ $convert x$ >> | Array x -> <:expr< fun x -> Array.of_list (($browse _loc "list"$ $convert x$) x) >> | Option x -> <:expr< $browse _loc "optional"$ $convert x$ >> | Object l -> convert_object _loc l | Record r -> convert_record _loc r | Hashtbl x -> <:expr< fun x -> let l = $browse _loc "objekt"$ x in let tbl = Hashtbl.create (List.length l) in do { List.iter (fun (s, x) -> Hashtbl.add tbl s ($convert x$ x)) l; tbl } >> | Assoc x -> <:expr< fun x -> List.map (fun (key, data) -> (key, $convert x$ data)) ($browse _loc "objekt"$ x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun ((_loc, _), name) tl -> <:patt< [ $lid:name$ :: $tl$ ] >>) nl <:patt< [] >> in let el = List.map (fun ((_loc, _) as x, name) -> <:expr< $convert x$ $lid:name$ >>) nl in <:expr< fun [ Json_type.Array [ $list:pl$ ] -> ( $list:el$ ) | Json_type.Array _ as x -> __json_static_error x "wrong number of elements in JSON array" | x -> __json_static_error x "not a JSON array" ] >> | Poly l -> convert_variants (fun _loc name -> <:expr< ` $name$ >>) _loc l | Variant l -> convert_variants (fun _loc name -> <:expr< $uid:name$ >>) _loc l | Name x -> <:expr< $lid: x ^ "_of_json"$ >> | String -> browse _loc "string" | Bool -> browse _loc "bool" | Int -> browse _loc "int" | Float -> browse _loc "float" | Number -> browse _loc "number" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . of_json >> and convert_object _loc l = let pel = convert_field_list _loc l in let ml = List.map (fun x -> let name = x.field_caml_name in <:class_str_item< method $name$ = $lid:name$ >>) l in let obj = (* <:expr< object $list:ml$ end >> *) MLast.ExObj (_loc, None, ml) in eval_with_tbl _loc <:expr< let $list:pel$ in $obj$ >> and convert_record _loc r = let pel = convert_field_list _loc r in eval_with_tbl _loc <:expr< { $list:pel$ } >> and convert_field_list _loc l = List.map (fun { field_caml_name = name; field_json_name = json_name; field_type = x; optional = optional; default = default; validator_name = validate_opt } -> let validate e = match validate_opt with None -> e | Some f -> <:expr< let x = $e$ in do { $lid:f$ x; x } >> in let e1 = let f = if optional then "fieldx" else "field" in <:expr< (Json_type.Browse.$lid:f$ tbl $str:json_name$) >> in let e2 = match default with Some e -> (<:expr< match $e1$ with [ Json_type.Null -> $e$ | x -> $convert x$ x ] >>) | None -> <:expr< $convert x$ $e1$ >> in (<:patt< $lid:name$ >>, validate e2)) l and convert_variants make_cons _loc l = let l0, l1 = List.partition (fun x -> x.cons_args = []) l in let pwel0 = List.map (fun { cons_caml_name = name; cons_json_name = json_name } -> (<:patt< $str:json_name$ >>, None, make_cons _loc name)) l0 in let pwel1 = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> let argnames = numbered_list args in let list_patt = List.fold_right (fun (arg, s) l -> <:patt< [ $lid:s$ :: $l$ ] >>) argnames <:patt< [] >> in let e = List.fold_left (fun cons (arg, s) -> <:expr< $cons$ ($convert arg$ $lid:s$) >>) (make_cons _loc name) argnames in (<:patt< ($str:json_name$, $list_patt$) >>, None, e)) l1 in let full_pwel pwel = pwel @ [ <:patt< _ >>, None, <:expr< __json_static_error x "invalid variant name or \ wrong number of arguments" >> ] in (<:expr< fun [ Json_type.String s as x -> match s with [ $list:full_pwel pwel0$ ] | Json_type.Array [ Json_type.String s :: ([ _ :: _ ] as args) ] as x -> match (s, args) with [ $list:full_pwel pwel1$ ] | x -> __json_static_error x "not able to read this as \ a variant" ] >>) and eval_with_tbl _loc e = (<:expr< fun x -> let tbl = Json_type.Browse.make_table (Json_type.Browse.objekt x) in $e$ >>) in let defs = optmap (fun ((_loc, name), x) -> (*if x.is_private then None else*) let fname = name ^ "_of_json" in Some (<:patt< ( $lid:fname$ : Json_type.t -> $lid:name$ ) >>, eta_expand (convert x.def))) l in if defs = [] then <:str_item< declare end >> else <:str_item< declare value rec $list:defs$; end >> let make_tojson_val, make_tojson_defs = let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< Json_type.Build.list $convert x$ >> | Array x -> <:expr< fun x -> Json_type.Build.list $convert x$ (Array.to_list x) >> | Option x -> <:expr< Json_type.Build.optional $convert x$ >> | Object l -> convert_field_list (fun name -> <:expr< x#$lid:name$ >>) _loc l | Record r -> convert_field_list (fun name -> <:expr< x.$lid:name$ >>) _loc r | Hashtbl x -> <:expr< fun tbl -> Json_type.Object (Hashtbl.fold (fun key data tl -> [ (key, $convert x$ data) :: tl ]) tbl []) >> | Assoc x -> <:expr< fun x -> Json_type.Object ((List.map (fun (key, data) -> (key, $convert x$ data))) x) >> | Tuple l -> let nl = numbered_list l in let pl = List.map (fun (_, name) -> <:patt< $lid:name$ >>) nl in let a = List.fold_right (fun (x, name) tl -> <:expr< [ $convert x$ $lid:name$ :: $tl$ ] >>) nl <:expr< [] >> in <:expr< fun [ ( $list:pl$ ) -> Json_type.Array $a$ ] >> | Poly l -> let pwel = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> (<:patt< ` $name$ >>, None, <:expr< Json_type.String $str:json_name$ >>) | [x] -> (<:patt< ` $name$ arg >>, None, <:expr< Json_type.Array [ Json_type.String $str:json_name$; $convert x$ arg ] >>) | _ -> assert false) l in <:expr< fun [ $list:pwel$ ] >> | Variant v -> let pwel = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> (<:patt< $uid:name$ >>, None, <:expr< Json_type.String $str:json_name$ >>) | l -> let args = numbered_list l in let p = List.fold_left (fun cons (_, s) -> <:patt< $cons$ $lid:s$ >>) <:patt< $uid:name$ >> args in let e = List.fold_right (fun (x, s) l -> <:expr< [ $convert x$ $lid:s$ :: $l$ ] >>) args <:expr< [] >> in (p, None, <:expr< Json_type.Array [ Json_type.String $str:json_name$ :: $e$ ] >>)) v in <:expr< fun [ $list:pwel$ ] >> | Name x -> <:expr< $lid: "json_of_" ^ x$ >> | String -> build _loc "string" | Bool -> build _loc "bool" | Int -> build _loc "int" | Float -> build _loc "float" | Number -> build _loc "float" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . to_json >> and convert_field_list access _loc l = let pairs = List.fold_right (fun { field_caml_name = name; field_json_name = json_name; field_type = x } tl -> <:expr< [ ( $str:json_name$, $convert x$ $access name$ ) :: $tl$ ] >>) l <:expr< [] >> in <:expr< fun x -> Json_type.Object $pairs$ >> in let make_defs _loc l = let defs = List.map (fun ((_loc, name), x) -> let fname = "json_of_" ^ name in (<:patt< ( $lid:fname$ : $lid:name$ -> Json_type.t ) >>, eta_expand (convert x.def))) l in <:str_item< value rec $list:defs$ >> in (convert, make_defs) let make_typedef _loc names l = let rec convert (_loc, def) = match def with List x -> <:ctyp< list $convert x$ >> | Array x -> <:ctyp< array $convert x$ >> | Option x -> <:ctyp< option $convert x$ >> | Object l -> let ml = List.map (fun x -> (x.field_caml_name, convert x.field_type)) l in <:ctyp< < $list:ml$ > >> | Record r -> let l = List.map (fun x -> (x.field_caml_loc, x.field_caml_name, x.is_mutable, convert x.field_type)) r in <:ctyp< { $list:l$ } >> | Hashtbl x -> <:ctyp< Hashtbl.t string $convert x$ >> | Assoc x -> <:ctyp< list (string * $convert x$) >> | Tuple l -> let tl = List.map convert l in <:ctyp< ( $list:tl$ ) >> | Poly l -> let rfl = List.map (fun c -> let name = c.cons_caml_name in match c.cons_args with [] -> MLast.RfTag (name, true, []) | [x] -> MLast.RfTag (name, false, [convert x]) | _ -> assert false) l in <:ctyp< [ = $list:rfl$ ] >> | Variant v -> let l = List.map (fun x -> let cal = List.map convert x.cons_args in (x.cons_caml_loc, x.cons_caml_name, cal)) v in <:ctyp< [ $list:l$ ] >> | Name x -> if StringMap.mem x names then <:ctyp< $lid:x$ >> else Stdpp.raise_with_loc _loc (Failure ("type name " ^ x ^ " is undefined or not defined in the same \ 'type ... and ...' block")) | String -> <:ctyp< string >> | Bool -> <:ctyp< bool >> | Int -> <:ctyp< int >> | Float -> <:ctyp< float >> | Number -> <:ctyp< float >> | Raw -> <:ctyp< Json_type.t >> | Custom s -> <:ctyp< $uid:s$ . t >> in let tdl = optmap (fun (name, x) -> if x.is_predefined then None else let ctyp = convert x.def in Some (name, [], ctyp, [])) l in if tdl <> [] then <:str_item< type $list:tdl$ >> else <:str_item< declare end >> let make_typeval _loc l = let bool _loc b = if b then <:expr< True >> else <:expr< False >> in let run = <:expr< $uid:"Run_json_static"$ >> in let additional_defs = ref [] in let rec convert (_loc, def) = match def with List x -> <:expr< $run$.List $convert x$ >> | Array x -> <:expr< $run$.Array $convert x$ >> | Option x -> <:expr< $run$.Option $convert x$ >> | Object l -> <:expr< $run$.Object $make_fields _loc l$ >> | Record l -> <:expr< $run$.Record $make_fields _loc l$ >> | Hashtbl x -> <:expr< $run$.Hashtbl $convert x$ >> | Assoc x -> <:expr< $run$.Assoc $convert x$ >> | Tuple l -> let tl = List.fold_right (fun x l -> <:expr< [ $convert x$ :: $l$ ] >>) l <:expr< [] >> in <:expr< $run$.Tuple $tl$ >> | Poly l -> <:expr< $run$.Poly $make_constructors _loc l$ >> | Variant l -> <:expr< $run$.Variant $make_constructors _loc l$ >> | Name x -> <:expr< $run$.Name $str:x$ >> | String -> <:expr< $run$.String >> | Bool -> <:expr< $run$.Bool >> | Int -> <:expr< $run$.Int >> | Float -> <:expr< $run$.Float >> | Number -> <:expr< $run$.Number >> | Raw -> <:expr< $run$.Raw >> | Custom s -> <:expr< $uid:s$ . typedef >> and make_field _loc (x : field) = let to_json = new_id "to_json" in let json_default_value = new_id "json_default_value" in let get_json_subset = new_id "get_json_subset" in let validate_abstract_subset mem = <:expr< fun x -> if not $mem$ then __json_static_error ($lid:to_json$ x) "invalid field value: not in valid subset" else () >> in let validate_list_subset list = validate_abstract_subset <:expr< List.mem x $list$ >> in let validate_dynlist_subset get_list = validate_list_subset <:expr< $get_list$ () >> in let has_default = x.default <> None in let has_subset = x.subset <> None in let tojson_def = if not has_default && not has_subset then <:str_item< declare end >> else let e1 = make_tojson_val x.field_type in <:str_item< value $lid:to_json$ = $e1$ >> in let validator = match x.subset with None -> <:str_item< value $lid:get_json_subset$ = None >> | Some set -> let lid s = <:expr< $lid:s$ >> in let lidx s = <:expr< $lid:s$ x >> in let e1 = match set with `List e -> <:expr< let list = $e$ in let json_list = List.map $lid:to_json$ list in ( Some (`List json_list), $validate_list_subset (lid "list")$ ) >> | `Dynlist get_list -> <:expr< let get_list = $get_list$ in let get_json_list () = List.map $lid:to_json$ (get_list ()) in ( Some (`Dynlist get_json_list), $validate_dynlist_subset (lid "get_list")$ ) >> | `Abstract_set mem -> <:expr< let mem = $mem$ in ( Some `Abstract_set, $validate_abstract_subset (lidx "mem")$ ) >> in let validator_name = match x.validator_name with Some s -> s | None -> assert false in <:str_item< value ( $lid:get_json_subset$, $lid:validator_name$ ) = $e1$ >> in additional_defs := tojson_def :: !additional_defs; additional_defs := validator :: !additional_defs; let insert_default e2 = (* default value must be in subset *) match x.default with None -> <:expr< let $lid:json_default_value$ = None in $e2$ >> | Some e -> let _loc = MLast.loc_of_expr e in let e1 = if has_subset then let validator_name = match x.validator_name with Some s -> s | None -> assert false in <:expr< Some ( let default_value = $e$ in do { $lid:validator_name$ default_value; $lid:to_json$ default_value } ) >> else <:expr< Some ( $lid:to_json$ $e$ ) >> in <:expr< let $lid:json_default_value$ = $e1$ in $e2$ >> in (insert_default <:expr< { Run_json_static.field_caml_name = $str:x.field_caml_name$; field_json_name = $str:x.field_json_name$; field_type = $convert x.field_type$; optional = $bool _loc x.optional$; json_default = $lid:json_default_value$; json_subset = $lid:get_json_subset$; is_mutable = $bool _loc x.is_mutable$ } >>) and make_fields _loc (l : field list) = List.fold_right (fun field l -> let e = make_field _loc field in <:expr< [ $e$ :: $l$ ] >>) l <:expr< [] >> and make_constructors _loc l = List.fold_right (fun x l -> let args = List.fold_right (fun x l -> <:expr< [ $convert x$ :: $l$ ] >>) x.cons_args <:expr< [] >> in <:expr< [ { Run_json_static.cons_caml_name = $str:x.cons_caml_name$; cons_json_name = $str:x.cons_json_name$; cons_args = $args$ } :: $l$ ] >>) l <:expr< [] >> in let defs = optmap (fun ((_loc, name), x) -> let xname = name ^ "_typedef" in Some (<:patt< ( $lid:xname$ : Run_json_static.typedef ) >>, <:expr< { Run_json_static.typename = $str:name$; def = $convert x.def$; is_predefined = $bool _loc x.is_predefined$; is_private = $bool _loc x.is_private$ } >>)) l in if defs <> [] then let x = List.rev_append !additional_defs [ <:str_item< value $list:defs$ >> ] in <:str_item< declare $list:x$ end >> else <:str_item< declare end >> let expand_typedefs _loc l = check_unique (fun (name, x) -> name) l; let names = List.fold_left (fun m (((_loc, name), x) as data) -> StringMap.add name data m) StringMap.empty l in let typedef = make_typedef _loc names l in let typeval = if !light_mode then <:str_item< declare end >> else make_typeval _loc l in let ofjson = make_ofjson_defs _loc l in let tojson = make_tojson_defs _loc l in <:str_item< declare $error _loc$; $typedef$; $typeval$; $ofjson$; $tojson$; end >> let o2b = function None -> false | _ -> true let is_reserved = let l = [ "json"; "json_type"; "string"; "bool"; "int"; "float"; "number"; "assoc" ] in let tbl = Hashtbl.create 20 in List.iter (fun s -> Hashtbl.add tbl s ()) l; Hashtbl.mem tbl let find_and_remove k0 l0 = try let _loc, _, v = List.find (fun (_, k, _) -> k = k0) l0 in let removed, l = List.partition (fun (_, k, _) -> k = k0) l0 in if List.length removed <> 1 then Stdpp.raise_with_loc _loc (Failure ("this option is specified multiple times: " ^ k0)) else Some v, l with Not_found -> None, l0 let read_options _loc default options = let options = match options with None -> [] | Some l -> l in let options = match default with None -> options | Some e -> (MLast.loc_of_expr e, "default", e) :: options in let default, options = find_and_remove "default" options in let list, options = find_and_remove "list_subset" options in let dynlist, options = find_and_remove "dynlist_subset" options in let abstract, options = find_and_remove "abstract_subset" options in if options <> [] then Stdpp.raise_with_loc _loc (Failure (sprintf "unknown options: %s" (String.concat ", " (List.map (fun (_, k, _) -> k) options)))) else let subset = ref None in let set r f o = match !r, o with None, Some x -> r := Some (f x) | Some _, Some _ -> Stdpp.raise_with_loc _loc (Failure "incompatible subset options") | _ -> () in set subset (fun e -> `List e) list; set subset (fun e -> `Dynlist e) dynlist; set subset (fun e -> `Abstract_set e) abstract; default, !subset open Pcaml let list_of_opt = function None -> [] | Some x -> [x] let list_of_optlist = function None -> [] | Some x -> x let check_methods l = List.iter (fun x -> if x.is_mutable then Stdpp.raise_with_loc x.field_caml_loc (Failure "object fields cannot be made mutable")) l let string_assoc _loc = function (_loc, Tuple [ (_, String); (_, x) ]) -> (_loc, x) | (_, _) -> Stdpp.raise_with_loc _loc (Failure "must be of the form (string * ...) assoc") EXTEND GLOBAL: str_item; str_item: LEVEL "top" [ [ "type"; LIDENT "json"; l = LIST1 type_binding SEP "and" -> expand_typedefs _loc l ] ]; type_binding: [ [ name = [ s = LIDENT -> if is_reserved s then Stdpp.raise_with_loc _loc (Failure ("you can't use '" ^ s ^ "' as a type name")) else (_loc, s) ]; "="; p = OPT [ LIDENT "predefined" (* ; priv = OPT "private"*) -> (* priv <> None *) false ]; t = [ t = type_expr -> (t : t) | r = record -> (_loc, Record r) | v = variants -> (_loc, Variant v) ] -> let typedef = match p with None -> { is_predefined = false; is_private = false; def = t } | Some is_private -> { is_predefined = true; is_private = is_private; def = t } in (name, typedef) ] ]; record: [ [ "{"; l = methods; "}" -> l ] ]; variants: [ [ l = LIST1 [ id = [ id = UIDENT -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; typ = OPT [ "of"; x = LIST1 type_expr LEVEL "simple" SEP "*" -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_optlist typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; type_expr: [ "top" [ x = type_expr; "*"; l = LIST1 type_expr LEVEL "simple" SEP "*" -> (_loc, Tuple (x :: l)) ] | "simple" [ x = type_expr; LIDENT "list" -> (_loc, List x) | x = type_expr; LIDENT "array" -> (_loc, Array x) | x = type_expr; LIDENT "option" -> (_loc, Option x) | x = type_expr; LIDENT "assoc" -> (_loc, Assoc (string_assoc _loc x)) | "<"; l = methods; ">" -> check_methods l; (_loc, Object l) | "["; l = polymorphic_variants; "]" -> (_loc, Poly l) | "("; x = type_expr; ")" -> x | "("; LIDENT "string"; ","; x = type_expr; ")"; UIDENT "Hashtbl"; "."; LIDENT "t" -> (_loc, Hashtbl x) | name = LIDENT -> (_loc, Name name) | LIDENT "string" -> (_loc, String) | LIDENT "bool" -> (_loc, Bool) | LIDENT "int" -> (_loc, Int) | LIDENT "float" -> (_loc, Float) | LIDENT "number" -> (_loc, Number) | [ UIDENT "Json_type"; "."; LIDENT "json_type" | LIDENT "json_type" ] -> (_loc, Raw) | module_name = UIDENT; "."; LIDENT "t" -> if module_name = "Json_type" then (_loc, Raw) else (_loc, Custom module_name) ] ]; polymorphic_variants: [ [ l = LIST1 [ "`"; id = [ id = [ LIDENT | UIDENT ] -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; typ = OPT [ "of"; x = type_expr -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_opt typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; methods: [ [ l = LIST0 [ mut = OPT "mutable"; lab = method_label; x = type_expr; options = OPT [ "{"; l = LIST0 option SEP ";"; "}" -> l ]; default = OPT [ "="; e = expr LEVEL "apply" -> e ]-> let ((id, optional), label) = lab in let id' = unopt id label in let default, subset = read_options _loc default options in let validator_name = if subset = None then None else Some (new_id "validate") in { field_caml_loc = fst id; field_caml_name = snd id; field_json_loc = fst id'; field_json_name = snd id'; field_type = x; optional = optional; default = default; subset = subset; validator_name = validator_name; is_mutable = (mut <> None) } ] SEP ";" -> check_unique (fun x -> (x.field_caml_loc, x.field_caml_name)) l; check_unique (fun x -> (x.field_json_loc, x.field_json_name)) l; l ] ]; option: [ [ k = LIDENT; "="; v = expr LEVEL "expr1" -> (_loc, k, v) ] ]; method_label: [ [ id_opt = [ id = LIDENT -> ((_loc, id), false) | id = QUESTIONIDENT -> ((_loc, id), true) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; ":" -> (id_opt, label) | id = OPTLABEL -> (((_loc, id), true), None) ] ]; END ;; let _ = Pcaml.add_option "-js-light" (Arg.Set light_mode) " no typedefs would be generated" json-static-0.9.8/yahoo.ml0000644000375200037520000000412111247725620015021 0ustar martinmartin(* OCaml script that queries the JSON interface of Yahoo! Image Search, and displays the results (not very nicely, but you can improve this part). What you need to compile this program: - json-wheel - json-static - netclient 1) Compile ocamlfind ocamlopt -o yahoo yahoo.ml -linkpkg \ -package json-static,netclient -syntax camlp4o 2) Run ./yahoo "Nelson Mandela" For more info on JSON and Yahoo! web services, go to http://developer.yahoo.com/common/json.html *) open Printf type json search_results = < result_set "ResultSet": < total_results_available "totalResultsAvailable": string; total_results_returned "totalResultsReturned": int; first_result_position "firstResultPosition": int; result "Result": item list > > and item = < title "Title": string; summary "Summary": string; url "Url": string; click_url "ClickUrl": string; referer_url "RefererUrl": string; file_size "FileSize": int; file_format "FileFormat": string option; height "Height": string; width "Width": string; thumbnail "Thumbnail": thumbnail > and thumbnail = < url "Url": string; height "Height": string; width "Width": string > let query_url query = "http://api.search.yahoo.com/ImageSearchService/V1/imageSearch?\ appid=YahooDemo&query=" ^ Netencoding.Url.encode query ^ "&output=json" let search query = let url = query_url query in printf "From %s\n%!" url; let j= (Json_io.json_of_string (Http_client.Convenience.http_get url)) in printf "Got the following JSON data:\n%s\n%!" (Json_io.string_of_json ~compact:false j); search_results_of_json j let display obj = let x = obj#result_set in let start = x#first_result_position in printf "Showing results %i-%i of %s\n" start (start + x#total_results_returned - 1) x#total_results_available; List.iter (fun x -> printf " %s\n" x#url) x#result let _ = match Sys.argv with [| _; q |] -> display (search q) | _ -> failwith "Usage: yahoo \"your search query\"" json-static-0.9.8/.svn/0000775000375200037520000000000011247725620014240 5ustar martinmartinjson-static-0.9.8/.svn/text-base/0000775000375200037520000000000011247725620016134 5ustar martinmartinjson-static-0.9.8/.svn/text-base/Camlp4Version.svn-base0000444000375200037520000000166211247725620022263 0ustar martinmartinifndef CAMLP4_VERSION CAMLP4_VERSION = \ $(shell if `which camlp4orf 2>/dev/null`; then echo 310; else echo 309; fi) endif export CAMLP4_VERSION ifndef CAMLP4ORF ifeq ($(CAMLP4_VERSION),309) CAMLP4ORF = camlp4o pa_extend.cmo q_MLast.cmo else CAMLP4ORF = camlp4orf endif endif export CAMLP4ORF ifndef CAMLP4RF ifeq ($(CAMLP4_VERSION),309) CAMLP4RF = camlp4r pa_extend.cmo q_MLast.cmo else CAMLP4RF = camlp4rf endif endif export CAMLP4RF ifndef PR_O ifeq ($(CAMLP4_VERSION),309) PR_O = pr_o.cmo else PR_O = -printer o endif endif export PR_O ifndef PR_R ifeq ($(CAMLP4_VERSION),309) PR_R = pr_r.cmo else PR_R = -printer r endif endif export PR_R ifndef PARSER ifeq ($(CAMLP4_VERSION),309) PARSER = else PARSER = -parser endif endif export PARSER ifndef PRINTER ifeq ($(CAMLP4_VERSION),309) PRINTER = else PRINTER = -printer endif endif export PRINTER json-static-0.9.8/.svn/text-base/Changes.svn-base0000444000375200037520000000170111247725620021137 0ustar martinmartin2009-09-03: 0.9.8 * Fixed bug leading "predefined" to be ignored if first in a group of type definitions. 2009-08-13: 0.9.7 * Fix allowing toplevel use 2008-02-04: 0.9.6 2007-04-02: 0.9.5 Added support for "the new camlp4" (3.10.0+beta) 2007-03-04: 0.9.4 * Fixed bug that occured with definitions like (string * int * int) list saying that an assoc type was expected. 2007-02-22: 0.9.3 * Added support for records and classic variants, possibly predefined. * Fixed bug "This kind of expression is not allowed as right-hand side of `let rec'" which occurred in cases like type json a = b list and b = int * Slightly improved conversion to polymorphic variants 2007-01-25: 0.9.2 Added support for association lists built from objects ("assoc") 2007-01-24: 0.9.1 Added support for optional object fields and default values 2007-01-19: 0.9.0 "Preview release" json-static-0.9.8/.svn/text-base/LICENSE.svn-base0000444000375200037520000000261111247725620020652 0ustar martinmartinCopyright (c) 2007 Burnham Institute for Medical Research All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. json-static-0.9.8/.svn/text-base/META.template.svn-base0000444000375200037520000000030211247725620022123 0ustar martinmartinname = "json-static" description = "statically-typed JSON data" requires = "camlp4 json-wheel" archive(syntax,toploop) = "pa_json_static.cmo" archive(syntax,preprocessor) = "pa_json_static.cmo" json-static-0.9.8/.svn/text-base/Makefile.svn-base0000444000375200037520000000466411247725620021317 0ustar martinmartininclude Camlp4Version VERSION = 0.9.8 export VERSION .PHONY: default all opt init common check test install uninstall .PHONY: clean meta doc archive demo default: all opt all: init common init: echo $$CAMLP4_VERSION echo $$CAMLP4ORF echo $$CAMLP4RF echo $$PR_O echo $$PR_R echo $$PARSER echo $$PRINTER echo '# 1 "pa_json_static.ml.$(CAMLP4_VERSION)"' > pa_json_static.ml cat pa_json_static.ml.$(CAMLP4_VERSION) >> pa_json_static.ml ln -sf pa_json_static.ml.annot pa_json_static.annot common: ocamlc -c -dtypes \ -pp '$(CAMLP4ORF) -loc _loc' \ -I +camlp4 pa_json_static.ml demo: yahoo ./yahoo "Nelson Mandela" test: check check: camlp4o -I . $(PR_O) $(PARSER) pa_json_static.cmo check.ml -o check.ppo # ocamlfind ocamlopt -c -package json-wheel -impl check.ppo ocamlfind ocamlc -i -package json-wheel \ -pp 'camlp4o -I . $(PARSER) pa_json_static.cmo' check.ml \ > check.mli.auto ocamlfind ocamlopt -o check -package json-wheel -linkpkg \ -pp 'camlp4o -I . $(PARSER) pa_json_static.cmo' \ check.ml ./check install: META ocamlfind install json-static META \ pa_json_static.cmi pa_json_static.cmo META: META.template Makefile echo 'version = "$(VERSION)"' > META cat META.template >> META uninstall: ocamlfind remove json-static clean: rm -f *.ppo *.ppr *.cmo *.cmi *.o *.cmx *.ast *~ *.auto *.annot \ check yahoo yahoo.ml.html test_typedefs.json \ pa_json_static.ml yahoo: yahoo.ml ocamlfind ocamlopt -o yahoo yahoo.ml -dtypes -linkpkg \ -package json-static,netclient -syntax camlp4o archive: rm -rf /tmp/json-static /tmp/json-static-$(VERSION) && \ cp -r . /tmp/json-static && \ cd /tmp/json-static && \ $(MAKE) clean && \ rm -f *~ json-static*.tar* && \ cd /tmp && cp -r json-static json-static-$(VERSION) && \ tar czf json-static.tar.gz json-static && \ tar cjf json-static.tar.bz2 json-static && \ tar czf json-static-$(VERSION).tar.gz json-static-$(VERSION) && \ tar cjf json-static-$(VERSION).tar.bz2 json-static-$(VERSION) mv /tmp/json-static.tar.gz /tmp/json-static.tar.bz2 . mv /tmp/json-static-$(VERSION).tar.gz /tmp/json-static-$(VERSION).tar.bz2 . cp json-static.tar.gz json-static.tar.bz2 $$WWW/ cp json-static-$(VERSION).tar.gz json-static-$(VERSION).tar.bz2 $$WWW/ cp LICENSE $$WWW/json-static-license.txt cp README $$WWW/json-static-readme.txt cp Changes $$WWW/json-static-changes.txt cp yahoo.ml $$WWW/ echo 'let json_static_version = "$(VERSION)"' \ > $$WWW/json-static-version.ml json-static-0.9.8/.svn/text-base/README.svn-base0000444000375200037520000002002711247725620020526 0ustar martinmartin json-static Introduction ============ json-static is a syntax extension of OCaml that can make the use of JSON data easier. From a special type declaration, the camlp4 preprocessor generates the code that converts between a JSON "abstract syntax tree" and specialized OCaml data structures such as objects, polymorphic variants, lists, arrays, tuples, etc. It will at the same time check that the structure of the JSON document is correct and produce OCaml data which is statically typed. For example, the following declaration defines the type of a point object: type json point = < x: float; y: float > This automatically makes two functions available, with the following signature: val json_of_point : point -> Json_type.t val point_of_json : Json_type.t -> point Json_type.t is the type of parsed JSON data, which is provided by the json-wheel library. Function json_of_point would convert an OCaml object of type point into a JSON object. point_of_json works the other way around, and fails by raising the Json_type.Json_error exception if the input JSON data doesn't have the right format. Installation ============ Installation: make make install Uninstallation: make uninstall Usage ===== Basically, you must preprocess your OCaml file(s) with camlp4o pa_json_static.cmo. Once installed using the standard procedure (ocamlfind), you can compile a file using these commands: # compile ocamlfind ocamlopt -c yourfile.ml -syntax camlp4o -package json-static # link ocamlfind ocamlopt -o yourprog yourfile.cmx -linkpkg -package json-wheel Build tools like OCamlMakefile take care of this nicely. Syntax ====== You must write a special type declaration that describes the expected format of the JSON data. There is a predefined mapping from OCaml types to JSON: OCaml type JSON type Properties of JSON data ---------- --------- ----------------------- string String float Number not an int int Number an int number* Number a float or an int bool Boolean list Array homogenous array Array homogenous tuple Array fixed length (string * 'a) assoc** Object an object read as an associative list (string, 'a) Hashtbl.t Object object or record Object additional methods/fields are ignored option any null means None polymorphic variants String or Array a String for constructors without an argument, or an Array of length 2 where the first element is a String that represents the constructor and the second element is the argument. classic variants String or Array a String for contructors without an argument, or an Array where the first element is the String that represents the constructor and the rest are the arguments. Unlike polymorphic variants, there may be several arguments (just don't use parentheses around them in the type definition). X.t*** defined by X.of_json and X.to_json --- *: the number type is an alias for float, but accepts JSON ints and converts them to OCaml floats. **: the assoc type is an alias for list, but converts from a JSON object. ***: X can be any simple module name, but module fields t, of_json and to_json are mandatory. A type definition is done like regular type definitions, but the keyword "json" is placed just after "type", as in: type json t = int * float ^^^^ The type cannot be polymorphic, i.e. it doesn't support type parameters. A small set of basic types are supported (see table above). Other type names can be used only if they are part of the same definition. This works: type json a = b and b = int list But the following doesn't work: type json b = int list type json a = b (* b is unknown to the preprocessor *) In addition to the basic syntax for type declarations, a few extensions have been added: 1) Object labels or variant names can be followed by an arbitrary string. When it is the case, this defines the string to be found in the JSON data. 2) Object methods can be preceded by a questionmark. If it is the case, JSON objects that do not have this field could still be read. Their value is set to null instead of being undefined and causing an error. 3) A default value can be specified a after a method definition. The syntax is a "=" followed by an expression. The expression should be a constant. The default expression is used whenever the JSON null value is encountered, even if the type converter knows how to deal with null. 4) Records and variant types must be named, as always in OCaml. Reusing an existing definition is possible by using the "predefined" keyword as in type point = predefined { x : float; y : float } or type t = predefined A | B of bool * t Predefined read-only records or variant types (private) cannot be used as of version 0.9.3 of this program. A common use of optional methods without a default argument is when omitting an object field is allowed and considered equivalent to a null value. Optional methods of a type that doesn't accept the null value don't make much sense but are not rejected. The following is most likely an error: type json point = < ?x : int > (if field "x" is not found in the JSON object, then the error would be that null is not a valid int, instead of saying that field "x" is missing) It should be either type json point = < ?x : int option > or type json point = < ?x : int = 0 > Example 1 ========= The following definition is correct: type json point = < x: number; y: number > and coords = point array It can load successfully the following JSON data: [ { "x": 1, "y": 0.5 }, { "x": 0, "y": 0.3333333 } ] Full example: (* File example1.ml *) type json point = < x: number; y: number > and coords = point array let json_string = " [ { \"x\": 1, \"y\": 0.5 }, { \"x\": 0, \"y\": 0.3333333 } ] " let json_tree = Json_io.json_of_string json_string let my_coords = coords_of_json json_tree let _ = Array.iter (fun p -> Printf.printf "(%g, %g)\n" p#x p#y) my_coords (* EOF *) Save the example as "example1.ml", compile it and run it: $ ocamlfind ocamlopt -o example1 -linkpkg -package json-static -syntax camlp4o example1.ml $ ./example1 (1, 0.5) (0, 0.333333) Example 2 ========= This example shows you the representation that we chose for sum types in JSON: (* File example2.ml *) type json colors = [ `Black | `White | `Rgb of (float * float * float) | `Any "*" ] list let my_colors = [ `Black; `White; `Any; `Rgb (1., 0., 0.); `Rgb (0., 1., 0.); `Rgb (0., 0., 1.) ] let _ = print_endline (Json_io.string_of_json (json_of_colors my_colors)) (* EOF *) $ ocamlfind ocamlopt -o example2 -linkpkg -package json-static -syntax camlp4o example2.ml $ ./example2 [ "Black", "White", "*", [ "Rgb", [ 1.0, 0.0, 0.0 ] ], [ "Rgb", [ 0.0, 1.0, 0.0 ] ], [ "Rgb", [ 0.0, 0.0, 1.0 ] ] ] Note how we specified that `Any translates into "*" rather than "Any". The same technique is available to rename object methods, and it is crucial when some existing JSON format uses method names that are not valid OCaml identifiers. json-static-0.9.8/.svn/text-base/check.ml.svn-base0000444000375200037520000000102111247725620021246 0ustar martinmartin(* Initialization commands to type in the ocaml toplevel: #use "topfind";; #camlp4o;; #require "json-wheel";; #load "pa_json_static.cmo";; *) (**************** Miscellaneous tests (should compile fine) ************) type coord = { x : int; y : int; z : int } type json variant = A | B of coord | C of float * variant | D of (bool * int option) and coord = predefined { x : int; y : int; z : int } type json a = b list and b = int type json c = (string * d * d) list and d = [ `A ] json-static-0.9.8/.svn/text-base/pa_json_static.ml.309.svn-base0000444000375200037520000006505511247725620023524 0ustar martinmartin(* Conversion between OCaml types and JSON types as provided by the json-wheel library. Author: Martin Jambon Copyright (c) 2007 Burnham Institute for Medical Research Copyright (c) 2007 Wink Technologies Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) open Printf let light_mode = ref false let reserved_prefix = "__json_static_" let new_id = let n = ref 0 in fun name -> incr n; reserved_prefix ^ name ^ string_of_int !n let check_unique f l = let tbl = Hashtbl.create 50 in List.iter (fun x -> let (_loc, id) = f x in if Hashtbl.mem tbl id then Stdpp.raise_with_loc _loc (Failure "this tag or label is not unique") else Hashtbl.add tbl id ()) l let unopt default = function None -> default | Some x -> x let rec optmap f = function [] -> [] | hd :: tl -> match f hd with None -> optmap f tl | Some x -> x :: optmap f tl type field = { field_caml_name : string; field_json_name : string; field_type : t; field_caml_loc : Token.flocation; field_json_loc : Token.flocation; optional : bool; default : MLast.expr option; subset : subset option; validator_name : string option; is_mutable : bool } and subset = [ `List of MLast.expr | `Dynlist of MLast.expr | `Abstract_set of MLast.expr ] and constructor = { cons_caml_name : string; cons_json_name : string; cons_args : t list; cons_caml_loc : Token.flocation; cons_json_loc : Token.flocation } and type_expr = List of t | Array of t | Option of t | Object of field list | Record of field list | Hashtbl of t | Assoc of t | Tuple of t list | Variant of constructor list | Poly of constructor list | Name of string | String | Bool | Int | Float | Number | Raw | Custom of string and t = Token.flocation * type_expr and typedef = { def : t; is_predefined : bool; is_private : bool (* unused at the moment *) } module StringMap = Map.Make (String) let error _loc = <:str_item< value __json_static_error obj msg = let m = 400 in let s = Json_io.string_of_json obj in let obj_string = if String.length s > m then String.sub s 0 (m - 4) ^ " ..." else s in Json_type.json_error (msg ^ ":\n" ^ obj_string) >> let numbered_list l = Array.to_list (Array.mapi (fun i x -> (x, "x" ^ string_of_int i)) (Array.of_list l)) let eta_expand = function (<:expr< fun [ $list:_$ ] >>) as f -> f | e -> let _loc = MLast.loc_of_expr e in (<:expr< fun x -> $e$ x >>) let make_ofjson_defs _loc l = let browse _loc f = <:expr< Json_type.Browse.$lid:f$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< $browse _loc "list"$ $convert x$ >> | Array x -> <:expr< fun x -> Array.of_list (($browse _loc "list"$ $convert x$) x) >> | Option x -> <:expr< $browse _loc "optional"$ $convert x$ >> | Object l -> convert_object _loc l | Record r -> convert_record _loc r | Hashtbl x -> <:expr< fun x -> let l = $browse _loc "objekt"$ x in let tbl = Hashtbl.create (List.length l) in do { List.iter (fun (s, x) -> Hashtbl.add tbl s ($convert x$ x)) l; tbl } >> | Assoc x -> <:expr< fun x -> List.map (fun (key, data) -> (key, $convert x$ data)) ($browse _loc "objekt"$ x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun ((_loc, _), name) tl -> <:patt< [ $lid:name$ :: $tl$ ] >>) nl <:patt< [] >> in let el = List.map (fun ((_loc, _) as x, name) -> <:expr< $convert x$ $lid:name$ >>) nl in <:expr< fun [ Json_type.Array [ $list:pl$ ] -> ( $list:el$ ) | Json_type.Array _ as x -> __json_static_error x "wrong number of elements in JSON array" | x -> __json_static_error x "not a JSON array" ] >> | Poly l -> convert_variants (fun _loc name -> <:expr< ` $name$ >>) _loc l | Variant l -> convert_variants (fun _loc name -> <:expr< $uid:name$ >>) _loc l | Name x -> <:expr< $lid: x ^ "_of_json"$ >> | String -> browse _loc "string" | Bool -> browse _loc "bool" | Int -> browse _loc "int" | Float -> browse _loc "float" | Number -> browse _loc "number" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . of_json >> and convert_object _loc l = let pel = convert_field_list _loc l in let ml = List.map (fun x -> let name = x.field_caml_name in <:class_str_item< method $name$ = $lid:name$ >>) l in let obj = (* <:expr< object $list:ml$ end >> *) MLast.ExObj (_loc, None, ml) in eval_with_tbl _loc <:expr< let $list:pel$ in $obj$ >> and convert_record _loc r = let pel = convert_field_list _loc r in eval_with_tbl _loc <:expr< { $list:pel$ } >> and convert_field_list _loc l = List.map (fun { field_caml_name = name; field_json_name = json_name; field_type = x; optional = optional; default = default; validator_name = validate_opt } -> let validate e = match validate_opt with None -> e | Some f -> <:expr< let x = $e$ in do { $lid:f$ x; x } >> in let e1 = let f = if optional then "fieldx" else "field" in <:expr< (Json_type.Browse.$lid:f$ tbl $str:json_name$) >> in let e2 = match default with Some e -> (<:expr< match $e1$ with [ Json_type.Null -> $e$ | x -> $convert x$ x ] >>) | None -> <:expr< $convert x$ $e1$ >> in (<:patt< $lid:name$ >>, validate e2)) l and convert_variants make_cons _loc l = let l0, l1 = List.partition (fun x -> x.cons_args = []) l in let pwel0 = List.map (fun { cons_caml_name = name; cons_json_name = json_name } -> (<:patt< $str:json_name$ >>, None, make_cons _loc name)) l0 in let pwel1 = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> let argnames = numbered_list args in let list_patt = List.fold_right (fun (arg, s) l -> <:patt< [ $lid:s$ :: $l$ ] >>) argnames <:patt< [] >> in let e = List.fold_left (fun cons (arg, s) -> <:expr< $cons$ ($convert arg$ $lid:s$) >>) (make_cons _loc name) argnames in (<:patt< ($str:json_name$, $list_patt$) >>, None, e)) l1 in let full_pwel pwel = pwel @ [ <:patt< _ >>, None, <:expr< __json_static_error x "invalid variant name or \ wrong number of arguments" >> ] in (<:expr< fun [ Json_type.String s as x -> match s with [ $list:full_pwel pwel0$ ] | Json_type.Array [ Json_type.String s :: ([ _ :: _ ] as args) ] as x -> match (s, args) with [ $list:full_pwel pwel1$ ] | x -> __json_static_error x "not able to read this as \ a variant" ] >>) and eval_with_tbl _loc e = (<:expr< fun x -> let tbl = Json_type.Browse.make_table (Json_type.Browse.objekt x) in $e$ >>) in let defs = optmap (fun ((_loc, name), x) -> (*if x.is_private then None else*) let fname = name ^ "_of_json" in Some (<:patt< ( $lid:fname$ : Json_type.t -> $lid:name$ ) >>, eta_expand (convert x.def))) l in if defs = [] then <:str_item< declare end >> else <:str_item< declare value rec $list:defs$; end >> let make_tojson_val, make_tojson_defs = let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< Json_type.Build.list $convert x$ >> | Array x -> <:expr< fun x -> Json_type.Build.list $convert x$ (Array.to_list x) >> | Option x -> <:expr< Json_type.Build.optional $convert x$ >> | Object l -> convert_field_list (fun name -> <:expr< x#$lid:name$ >>) _loc l | Record r -> convert_field_list (fun name -> <:expr< x.$lid:name$ >>) _loc r | Hashtbl x -> <:expr< fun tbl -> Json_type.Object (Hashtbl.fold (fun key data tl -> [ (key, $convert x$ data) :: tl ]) tbl []) >> | Assoc x -> <:expr< fun x -> Json_type.Object ((List.map (fun (key, data) -> (key, $convert x$ data))) x) >> | Tuple l -> let nl = numbered_list l in let pl = List.map (fun (_, name) -> <:patt< $lid:name$ >>) nl in let a = List.fold_right (fun (x, name) tl -> <:expr< [ $convert x$ $lid:name$ :: $tl$ ] >>) nl <:expr< [] >> in <:expr< fun [ ( $list:pl$ ) -> Json_type.Array $a$ ] >> | Poly l -> let pwel = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> (<:patt< ` $name$ >>, None, <:expr< Json_type.String $str:json_name$ >>) | [x] -> (<:patt< ` $name$ arg >>, None, <:expr< Json_type.Array [ Json_type.String $str:json_name$; $convert x$ arg ] >>) | _ -> assert false) l in <:expr< fun [ $list:pwel$ ] >> | Variant v -> let pwel = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> (<:patt< $uid:name$ >>, None, <:expr< Json_type.String $str:json_name$ >>) | l -> let args = numbered_list l in let p = List.fold_left (fun cons (_, s) -> <:patt< $cons$ $lid:s$ >>) <:patt< $uid:name$ >> args in let e = List.fold_right (fun (x, s) l -> <:expr< [ $convert x$ $lid:s$ :: $l$ ] >>) args <:expr< [] >> in (p, None, <:expr< Json_type.Array [ Json_type.String $str:json_name$ :: $e$ ] >>)) v in <:expr< fun [ $list:pwel$ ] >> | Name x -> <:expr< $lid: "json_of_" ^ x$ >> | String -> build _loc "string" | Bool -> build _loc "bool" | Int -> build _loc "int" | Float -> build _loc "float" | Number -> build _loc "float" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . to_json >> and convert_field_list access _loc l = let pairs = List.fold_right (fun { field_caml_name = name; field_json_name = json_name; field_type = x } tl -> <:expr< [ ( $str:json_name$, $convert x$ $access name$ ) :: $tl$ ] >>) l <:expr< [] >> in <:expr< fun x -> Json_type.Object $pairs$ >> in let make_defs _loc l = let defs = List.map (fun ((_loc, name), x) -> let fname = "json_of_" ^ name in (<:patt< ( $lid:fname$ : $lid:name$ -> Json_type.t ) >>, eta_expand (convert x.def))) l in <:str_item< value rec $list:defs$ >> in (convert, make_defs) let make_typedef _loc names l = let rec convert (_loc, def) = match def with List x -> <:ctyp< list $convert x$ >> | Array x -> <:ctyp< array $convert x$ >> | Option x -> <:ctyp< option $convert x$ >> | Object l -> let ml = List.map (fun x -> (x.field_caml_name, convert x.field_type)) l in <:ctyp< < $list:ml$ > >> | Record r -> let l = List.map (fun x -> (x.field_caml_loc, x.field_caml_name, x.is_mutable, convert x.field_type)) r in <:ctyp< { $list:l$ } >> | Hashtbl x -> <:ctyp< Hashtbl.t string $convert x$ >> | Assoc x -> <:ctyp< list (string * $convert x$) >> | Tuple l -> let tl = List.map convert l in <:ctyp< ( $list:tl$ ) >> | Poly l -> let rfl = List.map (fun c -> let name = c.cons_caml_name in match c.cons_args with [] -> MLast.RfTag (name, true, []) | [x] -> MLast.RfTag (name, false, [convert x]) | _ -> assert false) l in <:ctyp< [ = $list:rfl$ ] >> | Variant v -> let l = List.map (fun x -> let cal = List.map convert x.cons_args in (x.cons_caml_loc, x.cons_caml_name, cal)) v in <:ctyp< [ $list:l$ ] >> | Name x -> if StringMap.mem x names then <:ctyp< $lid:x$ >> else Stdpp.raise_with_loc _loc (Failure ("type name " ^ x ^ " is undefined or not defined in the same \ 'type ... and ...' block")) | String -> <:ctyp< string >> | Bool -> <:ctyp< bool >> | Int -> <:ctyp< int >> | Float -> <:ctyp< float >> | Number -> <:ctyp< float >> | Raw -> <:ctyp< Json_type.t >> | Custom s -> <:ctyp< $uid:s$ . t >> in let tdl = optmap (fun (name, x) -> if x.is_predefined then None else let ctyp = convert x.def in Some (name, [], ctyp, [])) l in if tdl <> [] then <:str_item< type $list:tdl$ >> else <:str_item< declare end >> let make_typeval _loc l = let bool _loc b = if b then <:expr< True >> else <:expr< False >> in let run = <:expr< $uid:"Run_json_static"$ >> in let additional_defs = ref [] in let rec convert (_loc, def) = match def with List x -> <:expr< $run$.List $convert x$ >> | Array x -> <:expr< $run$.Array $convert x$ >> | Option x -> <:expr< $run$.Option $convert x$ >> | Object l -> <:expr< $run$.Object $make_fields _loc l$ >> | Record l -> <:expr< $run$.Record $make_fields _loc l$ >> | Hashtbl x -> <:expr< $run$.Hashtbl $convert x$ >> | Assoc x -> <:expr< $run$.Assoc $convert x$ >> | Tuple l -> let tl = List.fold_right (fun x l -> <:expr< [ $convert x$ :: $l$ ] >>) l <:expr< [] >> in <:expr< $run$.Tuple $tl$ >> | Poly l -> <:expr< $run$.Poly $make_constructors _loc l$ >> | Variant l -> <:expr< $run$.Variant $make_constructors _loc l$ >> | Name x -> <:expr< $run$.Name $str:x$ >> | String -> <:expr< $run$.String >> | Bool -> <:expr< $run$.Bool >> | Int -> <:expr< $run$.Int >> | Float -> <:expr< $run$.Float >> | Number -> <:expr< $run$.Number >> | Raw -> <:expr< $run$.Raw >> | Custom s -> <:expr< $uid:s$ . typedef >> and make_field _loc (x : field) = let to_json = new_id "to_json" in let json_default_value = new_id "json_default_value" in let get_json_subset = new_id "get_json_subset" in let validate_abstract_subset mem = <:expr< fun x -> if not $mem$ then __json_static_error ($lid:to_json$ x) "invalid field value: not in valid subset" else () >> in let validate_list_subset list = validate_abstract_subset <:expr< List.mem x $list$ >> in let validate_dynlist_subset get_list = validate_list_subset <:expr< $get_list$ () >> in let has_default = x.default <> None in let has_subset = x.subset <> None in let tojson_def = if not has_default && not has_subset then <:str_item< declare end >> else let e1 = make_tojson_val x.field_type in <:str_item< value $lid:to_json$ = $e1$ >> in let validator = match x.subset with None -> <:str_item< value $lid:get_json_subset$ = None >> | Some set -> let lid s = <:expr< $lid:s$ >> in let lidx s = <:expr< $lid:s$ x >> in let e1 = match set with `List e -> <:expr< let list = $e$ in let json_list = List.map $lid:to_json$ list in ( Some (`List json_list), $validate_list_subset (lid "list")$ ) >> | `Dynlist get_list -> <:expr< let get_list = $get_list$ in let get_json_list () = List.map $lid:to_json$ (get_list ()) in ( Some (`Dynlist get_json_list), $validate_dynlist_subset (lid "get_list")$ ) >> | `Abstract_set mem -> <:expr< let mem = $mem$ in ( Some `Abstract_set, $validate_abstract_subset (lidx "mem")$ ) >> in let validator_name = match x.validator_name with Some s -> s | None -> assert false in <:str_item< value ( $lid:get_json_subset$, $lid:validator_name$ ) = $e1$ >> in additional_defs := tojson_def :: !additional_defs; additional_defs := validator :: !additional_defs; let insert_default e2 = (* default value must be in subset *) match x.default with None -> <:expr< let $lid:json_default_value$ = None in $e2$ >> | Some e -> let _loc = MLast.loc_of_expr e in let e1 = if has_subset then let validator_name = match x.validator_name with Some s -> s | None -> assert false in <:expr< Some ( let default_value = $e$ in do { $lid:validator_name$ default_value; $lid:to_json$ default_value } ) >> else <:expr< Some ( $lid:to_json$ $e$ ) >> in <:expr< let $lid:json_default_value$ = $e1$ in $e2$ >> in (insert_default <:expr< { Run_json_static.field_caml_name = $str:x.field_caml_name$; field_json_name = $str:x.field_json_name$; field_type = $convert x.field_type$; optional = $bool _loc x.optional$; json_default = $lid:json_default_value$; json_subset = $lid:get_json_subset$; is_mutable = $bool _loc x.is_mutable$ } >>) and make_fields _loc (l : field list) = List.fold_right (fun field l -> let e = make_field _loc field in <:expr< [ $e$ :: $l$ ] >>) l <:expr< [] >> and make_constructors _loc l = List.fold_right (fun x l -> let args = List.fold_right (fun x l -> <:expr< [ $convert x$ :: $l$ ] >>) x.cons_args <:expr< [] >> in <:expr< [ { Run_json_static.cons_caml_name = $str:x.cons_caml_name$; cons_json_name = $str:x.cons_json_name$; cons_args = $args$ } :: $l$ ] >>) l <:expr< [] >> in let defs = optmap (fun ((_loc, name), x) -> let xname = name ^ "_typedef" in Some (<:patt< ( $lid:xname$ : Run_json_static.typedef ) >>, <:expr< { Run_json_static.typename = $str:name$; def = $convert x.def$; is_predefined = $bool _loc x.is_predefined$; is_private = $bool _loc x.is_private$ } >>)) l in if defs <> [] then let x = List.rev_append !additional_defs [ <:str_item< value $list:defs$ >> ] in <:str_item< declare $list:x$ end >> else <:str_item< declare end >> let expand_typedefs _loc l = check_unique (fun (name, x) -> name) l; let names = List.fold_left (fun m (((_loc, name), x) as data) -> StringMap.add name data m) StringMap.empty l in let typedef = make_typedef _loc names l in let typeval = if !light_mode then <:str_item< declare end >> else make_typeval _loc l in let ofjson = make_ofjson_defs _loc l in let tojson = make_tojson_defs _loc l in <:str_item< declare $error _loc$; $typedef$; $typeval$; $ofjson$; $tojson$; end >> let o2b = function None -> false | _ -> true let is_reserved = let l = [ "json"; "json_type"; "string"; "bool"; "int"; "float"; "number"; "assoc" ] in let tbl = Hashtbl.create 20 in List.iter (fun s -> Hashtbl.add tbl s ()) l; Hashtbl.mem tbl let find_and_remove k0 l0 = try let _loc, _, v = List.find (fun (_, k, _) -> k = k0) l0 in let removed, l = List.partition (fun (_, k, _) -> k = k0) l0 in if List.length removed <> 1 then Stdpp.raise_with_loc _loc (Failure ("this option is specified multiple times: " ^ k0)) else Some v, l with Not_found -> None, l0 let read_options _loc default options = let options = match options with None -> [] | Some l -> l in let options = match default with None -> options | Some e -> (MLast.loc_of_expr e, "default", e) :: options in let default, options = find_and_remove "default" options in let list, options = find_and_remove "list_subset" options in let dynlist, options = find_and_remove "dynlist_subset" options in let abstract, options = find_and_remove "abstract_subset" options in if options <> [] then Stdpp.raise_with_loc _loc (Failure (sprintf "unknown options: %s" (String.concat ", " (List.map (fun (_, k, _) -> k) options)))) else let subset = ref None in let set r f o = match !r, o with None, Some x -> r := Some (f x) | Some _, Some _ -> Stdpp.raise_with_loc _loc (Failure "incompatible subset options") | _ -> () in set subset (fun e -> `List e) list; set subset (fun e -> `Dynlist e) dynlist; set subset (fun e -> `Abstract_set e) abstract; default, !subset open Pcaml let list_of_opt = function None -> [] | Some x -> [x] let list_of_optlist = function None -> [] | Some x -> x let check_methods l = List.iter (fun x -> if x.is_mutable then Stdpp.raise_with_loc x.field_caml_loc (Failure "object fields cannot be made mutable")) l let string_assoc _loc = function (_loc, Tuple [ (_, String); (_, x) ]) -> (_loc, x) | (_, _) -> Stdpp.raise_with_loc _loc (Failure "must be of the form (string * ...) assoc") EXTEND GLOBAL: str_item; str_item: LEVEL "top" [ [ "type"; LIDENT "json"; l = LIST1 type_binding SEP "and" -> expand_typedefs _loc l ] ]; type_binding: [ [ name = [ s = LIDENT -> if is_reserved s then Stdpp.raise_with_loc _loc (Failure ("you can't use '" ^ s ^ "' as a type name")) else (_loc, s) ]; "="; p = OPT [ LIDENT "predefined" (* ; priv = OPT "private"*) -> (* priv <> None *) false ]; t = [ t = type_expr -> (t : t) | r = record -> (_loc, Record r) | v = variants -> (_loc, Variant v) ] -> let typedef = match p with None -> { is_predefined = false; is_private = false; def = t } | Some is_private -> { is_predefined = true; is_private = is_private; def = t } in (name, typedef) ] ]; record: [ [ "{"; l = methods; "}" -> l ] ]; variants: [ [ l = LIST1 [ id = [ id = UIDENT -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; typ = OPT [ "of"; x = LIST1 type_expr LEVEL "simple" SEP "*" -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_optlist typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; type_expr: [ "top" [ x = type_expr; "*"; l = LIST1 type_expr LEVEL "simple" SEP "*" -> (_loc, Tuple (x :: l)) ] | "simple" [ x = type_expr; LIDENT "list" -> (_loc, List x) | x = type_expr; LIDENT "array" -> (_loc, Array x) | x = type_expr; LIDENT "option" -> (_loc, Option x) | x = type_expr; LIDENT "assoc" -> (_loc, Assoc (string_assoc _loc x)) | "<"; l = methods; ">" -> check_methods l; (_loc, Object l) | "["; l = polymorphic_variants; "]" -> (_loc, Poly l) | "("; x = type_expr; ")" -> x | "("; LIDENT "string"; ","; x = type_expr; ")"; UIDENT "Hashtbl"; "."; LIDENT "t" -> (_loc, Hashtbl x) | name = LIDENT -> (_loc, Name name) | LIDENT "string" -> (_loc, String) | LIDENT "bool" -> (_loc, Bool) | LIDENT "int" -> (_loc, Int) | LIDENT "float" -> (_loc, Float) | LIDENT "number" -> (_loc, Number) | [ UIDENT "Json_type"; "."; LIDENT "json_type" | LIDENT "json_type" ] -> (_loc, Raw) | module_name = UIDENT; "."; LIDENT "t" -> if module_name = "Json_type" then (_loc, Raw) else (_loc, Custom module_name) ] ]; polymorphic_variants: [ [ l = LIST1 [ "`"; id = [ id = [ LIDENT | UIDENT ] -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; typ = OPT [ "of"; x = type_expr -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_opt typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; methods: [ [ l = LIST0 [ mut = OPT "mutable"; lab = method_label; x = type_expr; options = OPT [ "{"; l = LIST0 option SEP ";"; "}" -> l ]; default = OPT [ "="; e = expr LEVEL "apply" -> e ]-> let ((id, optional), label) = lab in let id' = unopt id label in let default, subset = read_options _loc default options in let validator_name = if subset = None then None else Some (new_id "validate") in { field_caml_loc = fst id; field_caml_name = snd id; field_json_loc = fst id'; field_json_name = snd id'; field_type = x; optional = optional; default = default; subset = subset; validator_name = validator_name; is_mutable = (mut <> None) } ] SEP ";" -> check_unique (fun x -> (x.field_caml_loc, x.field_caml_name)) l; check_unique (fun x -> (x.field_json_loc, x.field_json_name)) l; l ] ]; option: [ [ k = LIDENT; "="; v = expr LEVEL "expr1" -> (_loc, k, v) ] ]; method_label: [ [ id_opt = [ id = LIDENT -> ((_loc, id), false) | id = QUESTIONIDENT -> ((_loc, id), true) ]; label = OPT [ s = STRING -> (_loc, Token.eval_string _loc s) ]; ":" -> (id_opt, label) | id = OPTLABEL -> (((_loc, id), true), None) ] ]; END ;; let _ = Pcaml.add_option "-js-light" (Arg.Set light_mode) " no typedefs would be generated" json-static-0.9.8/.svn/text-base/pa_json_static.ml.310.svn-base0000444000375200037520000005240111247725620023503 0ustar martinmartin(* Conversion between OCaml types and JSON types as provided by the json-wheel library. Author: Martin Jambon Copyright (c) 2007 Burnham Institute for Medical Research Copyright (c) 2008 Martin Jambon All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (* This version was tested successfully with camlp4 3.10.0+beta. The upgrade from 3.09 to 3.10+beta was performed with the help of Nicolas Pouillard. Command that compiles this program: ocamlc -c -pp camlp4orf -I +camlp4 \ pa_json_static_3100beta.ml Before 3.10, it used to be: ocamlc -c -pp 'camlp4o q_MLast.cmo pa_extend.cmo' -I +camlp4 \ pa_json_static.ml Command that works for using this syntax extension when it is present in the current directory (not installed, no ocamlfind). It preprocesses a file that uses the json-static syntax and pretty-prints it to standard OCaml syntax: camlp4o -parser ./pa_json_static_3100beta.cmo -printer o example.ml Before 3.10, it used to be: camlp4o ./pa_json_static.cmo pr_o.cmo example.ml It passes the "make test" stage of the json-static package! *) open Camlp4.PreCast open Printf let check_unique f l = let tbl = Hashtbl.create 50 in List.iter (fun x -> let (_loc, id) = f x in if Hashtbl.mem tbl id then Loc.raise _loc (Failure "this tag or label is not unique") else Hashtbl.add tbl id ()) l let unopt default = function None -> default | Some x -> x let rec optmap f = function [] -> [] | hd :: tl -> match f hd with None -> optmap f tl | Some x -> x :: optmap f tl type field = { field_caml_name : string; field_json_name : string; field_type : t; field_caml_loc : Loc.t; field_json_loc : Loc.t; optional : bool; default : Ast.expr option; is_mutable : bool } and constructor = { cons_caml_name : string; cons_json_name : string; cons_args : t list; cons_caml_loc : Loc.t; cons_json_loc : Loc.t } and type_expr = List of t | Array of t | Option of t | Object of field list | Record of field list | Hashtbl of t | Assoc of t | Tuple of t list | Variant of constructor list | Poly of constructor list | Name of string | String | Bool | Int | Float | Number | Raw | Custom of string and t = Loc.t * type_expr and type_def = { def : t; is_predefined : bool; is_private : bool (* unused at the moment *) } module StringMap = Map.Make (String) let make_typedef _loc names l = let rec convert (_loc, def) = match def with List x -> <:ctyp< list $convert x$ >> | Array x -> <:ctyp< array $convert x$ >> | Option x -> <:ctyp< option $convert x$ >> | Object l -> (* (* Development version post-3.10.0+beta *) let ml = List.fold_right (fun x acc -> <:ctyp< $lid:x.field_caml_name$ : $convert x.field_type$ ; $acc$ >>) l <:ctyp<>> in <:ctyp< < $ml$ > >> in *) let ml = List.fold_right (fun x acc -> let field = <:ctyp< $lid:x.field_caml_name$ : $convert x.field_type$ >> in <:ctyp< $field$ ; $acc$ >>) l <:ctyp<>> in <:ctyp< < $ml$ > >> | Record r -> let l = List.fold_right begin fun x acc -> let _loc = x.field_caml_loc in let t = convert x.field_type in let t = if x.is_mutable then <:ctyp< mutable $t$ >> else t in (* (* Development version post-3.10.0+beta: *) <:ctyp< $lid:x.field_caml_name$ : $t$; $acc$ >> *) let field = <:ctyp< $lid:x.field_caml_name$ : $t$ >> in <:ctyp< $field$; $acc$ >> end r <:ctyp<>> in <:ctyp< { $l$ } >> | Hashtbl x -> <:ctyp< Hashtbl.t string $convert x$ >> | Assoc x -> <:ctyp< list (string * $convert x$) >> | Tuple l -> (* (* Development version post-3.10.0+beta: *) let tl = List.map convert l in <:ctyp< ( $tup:Ast.tySta_of_list tl$ ) >> *) let t = List.fold_right (fun x tup -> <:ctyp< $convert x$ * $tup$ >>) l <:ctyp< >> in <:ctyp< ( $tup:t$ ) >> | Poly l -> let rfl = List.fold_right (fun c acc -> let name = c.cons_caml_name in match c.cons_args with [] -> <:ctyp< `$name$ | $acc$ >> | [x] -> (* (* Development version post-3.10.0+beta: *) <:ctyp< `$name$ of $convert x$ | $acc$ >> *) let case = <:ctyp< `$name$ of $convert x$ >> in <:ctyp< $case$ | $acc$ >> | _ -> assert false) l <:ctyp<>> in <:ctyp< [ = $rfl$ ] >> | Variant v -> let l = List.fold_right (fun x acc -> let cal = List.map convert x.cons_args in let _loc = x.cons_caml_loc in (* (* Development version post-3.10.0+beta: *) <:ctyp< $uid:x.cons_caml_name$ of $list:cal$ | $acc$ >> *) let case = <:ctyp< $uid:x.cons_caml_name$ of $list:cal$ >> in <:ctyp< $case$ | $acc$ >>) v <:ctyp<>> in <:ctyp< [ $l$ ] >> | Name x -> if StringMap.mem x names then <:ctyp< $lid:x$ >> else Loc.raise _loc (Failure ("type name " ^ x ^ " is undefined or not defined in the same \ 'type ... and ...' block")) | String -> <:ctyp< string >> | Bool -> <:ctyp< bool >> | Int -> <:ctyp< int >> | Float -> <:ctyp< float >> | Number -> <:ctyp< float >> | Raw -> <:ctyp< Json_type.t >> | Custom s -> <:ctyp< $uid:s$ . t >> in let l = List.filter (fun (_, x) -> not x.is_predefined) l in match l with [] -> <:str_item< >> | ((_loc, name), x) :: l -> let tdl = let dcl = Ast.TyDcl (_loc, name, [], convert x.def, []) in List.fold_right ( fun ((_loc, name), x) acc -> let dcl = Ast.TyDcl (_loc, name, [], convert x.def, []) in <:ctyp< $dcl$ and $acc$ >> ) l dcl in <:str_item< type $tdl$ >> let numbered_list l = Array.to_list (Array.mapi (fun i x -> (x, "x" ^ string_of_int i)) (Array.of_list l)) let eta_expand = function <:expr< fun [ $_$ ] >> as f -> f | e -> let _loc = Ast.loc_of_expr e in <:expr< fun x -> $e$ x >> let make_ofjson _loc l = let browse _loc f = <:expr< Json_type.Browse.$lid:f$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< $browse _loc "list"$ $convert x$ >> | Array x -> <:expr< fun x -> Array.of_list (($browse _loc "list"$ $convert x$) x) >> | Option x -> <:expr< $browse _loc "optional"$ $convert x$ >> | Object l -> convert_object _loc l | Record r -> convert_record _loc r | Hashtbl x -> <:expr< fun x -> let l = $browse _loc "objekt"$ x in let tbl = Hashtbl.create (List.length l) in do { List.iter (fun (s, x) -> Hashtbl.add tbl s ($convert x$ x)) l; tbl } >> | Assoc x -> <:expr< fun x -> List.map (fun (key, data) -> (key, $convert x$ data)) ($browse _loc "objekt"$ x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun ((_loc, _), name) tl -> <:patt< [ $lid:name$ :: $tl$ ] >>) nl <:patt< [] >> in let el = List.fold_right (fun ((_loc, _) as x, name) acc -> <:expr< $convert x$ $lid:name$, $acc$ >>) nl <:expr<>> in <:expr< fun [ Json_type.Array $pl$ -> ( $tup:el$ ) | Json_type.Array _ as x -> __json_static_error x "wrong number of elements in JSON array" | x -> __json_static_error x "not a JSON array" ] >> | Poly l -> convert_variants (fun _loc name -> <:expr< ` $name$ >>) _loc l | Variant l -> convert_variants (fun _loc name -> <:expr< $uid:name$ >>) _loc l | Name x -> <:expr< $lid: x ^ "_of_json"$ >> | String -> browse _loc "string" | Bool -> browse _loc "bool" | Int -> browse _loc "int" | Float -> browse _loc "float" | Number -> browse _loc "number" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . of_json >> and convert_object _loc l = let pel = convert_object_field_list _loc l in let methods = List.fold_right (fun x acc -> let name = x.field_caml_name in <:class_str_item< method $name$ = $lid:name$ ; $acc$ >>) l <:class_str_item<>> in eval_with_tbl _loc <:expr< let $list:pel$ in object $methods$ end >> and convert_record _loc r = let pel = convert_record_field_list _loc r in eval_with_tbl _loc <:expr< { $list:pel$ } >> and convert_field_list _loc l = List.map (fun { field_caml_name = name; field_json_name = json_name; field_type = x; optional = optional; default = default } -> let e1 = let f = if optional then "fieldx" else "field" in <:expr< Json_type.Browse.$lid:f$ tbl $str:json_name$ >> in let e2 = match default with Some e -> (<:expr< match $e1$ with [ Json_type.Null -> $e$ | x -> $convert x$ x ] >>) | None -> <:expr< $convert x$ $e1$ >> in (name, e2)) l and convert_record_field_list _loc l = List.map (fun (name, e) -> <:rec_binding< $lid:name$ = $e$ >>) (convert_field_list _loc l) and convert_object_field_list _loc l = List.map (fun (name, e) -> <:binding< $lid:name$ = $e$ >>) (convert_field_list _loc l) and convert_variants make_cons _loc l = let l0, l1 = List.partition (fun x -> x.cons_args = []) l in let pwel0 = List.fold_right (fun { cons_caml_name = name; cons_json_name = json_name } acc -> <:match_case< $str:json_name$ -> $make_cons _loc name$ | $acc$ >>) l0 <:match_case<>> in let pwel1 = List.fold_right (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } acc -> let argnames = numbered_list args in let list_patt = List.fold_right (fun (_, s) l -> <:patt< [ $lid:s$ :: $l$ ] >>) argnames <:patt< [] >> in let e = List.fold_left (fun cons (arg, s) -> <:expr< $cons$ ($convert arg$ $lid:s$) >>) (make_cons _loc name) argnames in <:match_case< ($str:json_name$, $list_patt$) -> $e$ | $acc$ >>) l1 <:match_case<>> in let default_case = <:match_case< _ -> __json_static_error x "invalid variant name or \ wrong number of arguments" >> in (<:expr< fun [ Json_type.String s as x -> match s with [ $pwel0$ | $default_case$ ] | Json_type.Array [ Json_type.String s :: ([ _ :: _ ] as args) ] as x -> match (s, args) with [ $pwel1$ | $default_case$ ] | x -> __json_static_error x "not able to read this as \ a variant" ] >>) and eval_with_tbl _loc e = (<:expr< fun x -> let tbl = Json_type.Browse.make_table (Json_type.Browse.objekt x) in $e$ >>) in let error = <:str_item< value __json_static_error obj msg = let m = 400 in let s = Json_io.string_of_json obj in let obj_string = if String.length s > m then String.sub s 0 (m - 4) ^ " ..." else s in Json_type.json_error (msg ^ ":\n" ^ obj_string) >> in let defs = List.fold_right (fun ((_loc, name), x) acc -> (*if x.is_private then acc else*) let fname = name ^ "_of_json" in <:binding< ( $lid:fname$ : Json_type.t -> $lid:name$ ) = $eta_expand (convert x.def)$ and $acc$ >>) l <:binding<>> in <:str_item< $error$; value rec $defs$ >> let make_tojson _loc l = let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< Json_type.Build.list $convert x$ >> | Array x -> <:expr< fun x -> Json_type.Build.list $convert x$ (Array.to_list x) >> | Option x -> <:expr< Json_type.Build.optional $convert x$ >> | Object l -> convert_field_list (fun name -> <:expr< x#$lid:name$ >>) _loc l | Record r -> convert_field_list (fun name -> <:expr< x.$lid:name$ >>) _loc r | Hashtbl x -> <:expr< fun tbl -> Json_type.Object (Hashtbl.fold (fun key data tl -> [ (key, $convert x$ data) :: tl ]) tbl []) >> | Assoc x -> <:expr< fun x -> Json_type.Object ((List.map (fun (key, data) -> (key, $convert x$ data))) x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun (_, name) acc -> <:patt< $lid:name$, $acc$ >>) nl <:patt<>> in let a = List.fold_right (fun (x, name) tl -> <:expr< [ $convert x$ $lid:name$ :: $tl$ ] >>) nl <:expr< [] >> in <:expr< fun [ ( $tup:pl$ ) -> Json_type.Array $a$ ] >> | Poly l -> let match_cases = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> <:match_case< `$name$ -> Json_type.String $str:json_name$ >> | [x] -> <:match_case< `$name$ arg -> Json_type.Array [ Json_type.String $str:json_name$; $convert x$ arg ] >> | _ -> assert false) l in <:expr< fun [ $list:match_cases$ ] >> | Variant v -> let match_cases = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> <:match_case< $uid:name$ -> Json_type.String $str:json_name$ >> | l -> let args = numbered_list l in let p = List.fold_left (fun cons (_, s) -> <:patt< $cons$ $lid:s$ >>) <:patt< $uid:name$ >> args in let e = List.fold_right (fun (x, s) l -> <:expr< [ $convert x$ $lid:s$ :: $l$ ] >>) args <:expr< [] >> in <:match_case< $p$ -> Json_type.Array [ Json_type.String $str:json_name$ :: $e$ ] >>) v in <:expr< fun [ $list:match_cases$ ] >> | Name x -> <:expr< $lid: "json_of_" ^ x$ >> | String -> build _loc "string" | Bool -> build _loc "bool" | Int -> build _loc "int" | Float -> build _loc "float" | Number -> build _loc "float" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . to_json >> and convert_field_list access _loc l = let pairs = List.fold_right (fun { field_caml_name = name; field_json_name = json_name; field_type = x } tl -> <:expr< [ ( $str:json_name$, $convert x$ $access name$ ) :: $tl$ ] >>) l <:expr< [] >> in <:expr< fun x -> Json_type.Object $pairs$ >> in let defs = List.fold_right (fun ((_loc, name), x) acc -> let fname = "json_of_" ^ name in <:binding< ( $lid:fname$ : $lid:name$ -> Json_type.t ) = $eta_expand (convert x.def)$ and $acc$ >>) l <:binding<>> in <:str_item< value rec $defs$ >> let expand_typedefs _loc l = check_unique (fun (name, _) -> name) l; let names = List.fold_left (fun m (((_loc, name), _) as data) -> StringMap.add name data m) StringMap.empty l in let typedef = make_typedef _loc names l in let ofjson = make_ofjson _loc l in let tojson = make_tojson _loc l in <:str_item< $typedef$; $ofjson$; $tojson$ >> let o2b = function None -> false | _ -> true let is_reserved = let l = [ "json"; "json_type"; "string"; "bool"; "int"; "float"; "number"; "assoc" ] in let tbl = Hashtbl.create 20 in List.iter (fun s -> Hashtbl.add tbl s ()) l; Hashtbl.mem tbl let list_of_opt = function None -> [] | Some x -> [x] let list_of_optlist = function None -> [] | Some x -> x let check_methods l = List.iter (fun x -> if x.is_mutable then Loc.raise x.field_caml_loc (Failure "object fields cannot be made mutable")) l let string_assoc _loc = function (_loc, Tuple [ (_, String); (_, x) ]) -> (_loc, x) | (_, _) -> Loc.raise _loc (Failure "must be of the form (string * ...) assoc") open Syntax let eval_string s = Camlp4.Struct.Token.Eval.string ~strict:() s EXTEND Gram GLOBAL: str_item; str_item: LEVEL "top" [ [ "type"; LIDENT "json"; l = LIST1 type_binding SEP "and" -> expand_typedefs _loc l ] ]; type_binding: [ [ name = [ s = LIDENT -> if is_reserved s then Loc.raise _loc (Failure ("you can't use '" ^ s ^ "' as a type name")) else (_loc, s) ]; "="; p = OPT [ LIDENT "predefined" (* ; priv = OPT "private"*) -> (* priv <> None *) false ]; t = [ t = type_expr -> (t : t) | r = record -> (_loc, Record r) | v = variants -> (_loc, Variant v) ] -> let type_def = match p with None -> { is_predefined = false; is_private = false; def = t } | Some is_private -> { is_predefined = true; is_private = is_private; def = t } in (name, type_def) ] ]; record: [ [ "{"; l = methods; "}" -> l ] ]; variants: [ [ l = LIST1 [ id = [ id = UIDENT -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; typ = OPT [ "of"; x = LIST1 type_expr LEVEL "simple" SEP "*" -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_optlist typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; type_expr: [ "top" [ x = type_expr; "*"; l = LIST1 type_expr LEVEL "simple" SEP "*" -> (_loc, Tuple (x :: l)) ] | "simple" [ x = type_expr; LIDENT "list" -> (_loc, List x) | x = type_expr; LIDENT "array" -> (_loc, Array x) | x = type_expr; LIDENT "option" -> (_loc, Option x) | x = type_expr; LIDENT "assoc" -> (_loc, Assoc (string_assoc _loc x)) | "<"; l = methods; ">" -> check_methods l; (_loc, Object l) | "["; l = polymorphic_variants; "]" -> (_loc, Poly l) | "("; x = type_expr; ")" -> x | "("; LIDENT "string"; ","; x = type_expr; ")"; UIDENT "Hashtbl"; "."; LIDENT "t" -> (_loc, Hashtbl x) | LIDENT "string" -> (_loc, String) | LIDENT "bool" -> (_loc, Bool) | LIDENT "int" -> (_loc, Int) | LIDENT "float" -> (_loc, Float) | LIDENT "number" -> (_loc, Number) | [ UIDENT "Json_type"; "."; LIDENT "json_type" | LIDENT "json_type" ] -> (_loc, Raw) | name = LIDENT -> (_loc, Name name) | module_name = UIDENT; "."; LIDENT "t" -> if module_name = "Json_type" then (_loc, Raw) else (_loc, Custom module_name) ] ]; polymorphic_variants: [ [ l = LIST1 [ "`"; id = [ `(LIDENT id | UIDENT id) -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; typ = OPT [ "of"; x = type_expr -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_opt typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; methods: [ [ l = LIST0 [ mut = OPT "mutable"; lab = method_label; x = type_expr; default = OPT [ "="; e = expr LEVEL "apply" -> e ] -> let ((id, optional), label) = lab in let id' = unopt id label in { field_caml_loc = fst id; field_caml_name = snd id; field_json_loc = fst id'; field_json_name = snd id'; field_type = x; optional = optional; default = default; is_mutable = (mut <> None) } ] SEP ";" -> check_unique (fun x -> (x.field_caml_loc, x.field_caml_name)) l; check_unique (fun x -> (x.field_json_loc, x.field_json_name)) l; l ] ]; method_label: [ [ id_opt = [ id = LIDENT -> ((_loc, id), false) | "?"; id = LIDENT -> ((_loc, id), true) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; ":" -> (id_opt, label) | id = OPTLABEL -> (((_loc, id), true), None) ] ]; END json-static-0.9.8/.svn/text-base/yahoo.ml.svn-base0000444000375200037520000000412111247725620021314 0ustar martinmartin(* OCaml script that queries the JSON interface of Yahoo! Image Search, and displays the results (not very nicely, but you can improve this part). What you need to compile this program: - json-wheel - json-static - netclient 1) Compile ocamlfind ocamlopt -o yahoo yahoo.ml -linkpkg \ -package json-static,netclient -syntax camlp4o 2) Run ./yahoo "Nelson Mandela" For more info on JSON and Yahoo! web services, go to http://developer.yahoo.com/common/json.html *) open Printf type json search_results = < result_set "ResultSet": < total_results_available "totalResultsAvailable": string; total_results_returned "totalResultsReturned": int; first_result_position "firstResultPosition": int; result "Result": item list > > and item = < title "Title": string; summary "Summary": string; url "Url": string; click_url "ClickUrl": string; referer_url "RefererUrl": string; file_size "FileSize": int; file_format "FileFormat": string option; height "Height": string; width "Width": string; thumbnail "Thumbnail": thumbnail > and thumbnail = < url "Url": string; height "Height": string; width "Width": string > let query_url query = "http://api.search.yahoo.com/ImageSearchService/V1/imageSearch?\ appid=YahooDemo&query=" ^ Netencoding.Url.encode query ^ "&output=json" let search query = let url = query_url query in printf "From %s\n%!" url; let j= (Json_io.json_of_string (Http_client.Convenience.http_get url)) in printf "Got the following JSON data:\n%s\n%!" (Json_io.string_of_json ~compact:false j); search_results_of_json j let display obj = let x = obj#result_set in let start = x#first_result_position in printf "Showing results %i-%i of %s\n" start (start + x#total_results_returned - 1) x#total_results_available; List.iter (fun x -> printf " %s\n" x#url) x#result let _ = match Sys.argv with [| _; q |] -> display (search q) | _ -> failwith "Usage: yahoo \"your search query\"" json-static-0.9.8/.svn/prop-base/0000775000375200037520000000000011247725620016130 5ustar martinmartinjson-static-0.9.8/.svn/prop-base/Makefile.svn-base0000444000375200037520000000003511247725620021277 0ustar martinmartinK 12 svn:keywords V 2 Id END json-static-0.9.8/.svn/prop-base/README.svn-base0000444000375200037520000000003511247725620020517 0ustar martinmartinK 12 svn:keywords V 2 Id END json-static-0.9.8/.svn/prop-base/check.ml.svn-base0000444000375200037520000000003511247725620021246 0ustar martinmartinK 12 svn:keywords V 2 Id END json-static-0.9.8/.svn/prop-base/yahoo.ml.svn-base0000444000375200037520000000003511247725620021310 0ustar martinmartinK 12 svn:keywords V 2 Id END json-static-0.9.8/.svn/props/0000775000375200037520000000000011247725620015403 5ustar martinmartinjson-static-0.9.8/.svn/tmp/0000775000375200037520000000000011247725620015040 5ustar martinmartinjson-static-0.9.8/.svn/tmp/text-base/0000775000375200037520000000000011247725620016734 5ustar martinmartinjson-static-0.9.8/.svn/tmp/prop-base/0000775000375200037520000000000011247725620016730 5ustar martinmartinjson-static-0.9.8/.svn/tmp/props/0000775000375200037520000000000011247725620016203 5ustar martinmartinjson-static-0.9.8/.svn/tmp/wcprops/0000775000375200037520000000000011247725620016535 5ustar martinmartinjson-static-0.9.8/.svn/entries0000444000375200037520000000352611247725620015636 0ustar martinmartin10 dir 3 svn+ssh://mjambon@svn.forge.ocamlcore.org/svnroot/json-static/trunk/json-static svn+ssh://mjambon@svn.forge.ocamlcore.org/svnroot/json-static 2009-08-12T23:01:19.784806Z 3 mjambon 623398bb-73e9-4733-bc06-1a81ec0b3817 META.template file 4 2009-09-03T11:34:08.081557Z 5ab46ae6baaffcaead7d11ef47646331 2009-09-03T11:46:56.125826Z 4 mjambon 194 pa_json_static.ml.309 file 2007-12-08T02:31:37.439135Z ef547a7737ee8865c8870206050ec977 2008-07-04T11:58:10.784200Z 1 mjambon 27181 LICENSE file 2007-04-19T20:48:12.063272Z f4abbb5d41a6133a8299e61922486e2e 2008-07-04T11:58:10.784200Z 1 mjambon 1417 check.ml file 4 2009-09-03T11:33:31.226985Z cc33e452290bd003b458c09acace4b06 2009-09-03T11:46:56.125826Z 4 mjambon has-props 529 run_json_static.mli file 4 deleted Camlp4Version file 2007-12-07T14:26:09.291731Z 9d28c77e0ff89ae313820e54e4e949f6 2008-07-04T11:58:10.784200Z 1 mjambon 946 yahoo.ml file 2008-02-04T15:09:31.983563Z 158abb8529787826937d2bb468e5bf2b 2008-07-04T11:58:10.784200Z 1 mjambon has-props 2129 Changes file 5 2009-09-03T11:41:39.453082Z 556a7f77cfc20328b6ec4bd1f1ec9369 2009-09-03T11:49:14.859458Z 5 mjambon 961 pa_json_static.ml.310 file 4 2009-09-03T11:26:05.371849Z 3b0aa095c2f6360a9a4cfc148b82a096 2009-09-03T11:46:56.125826Z 4 mjambon 21761 run_json_static.ml file 4 deleted Makefile file 4 2009-09-03T11:33:14.829838Z a1c9d0ff0694a99f19cda66a61a5c2aa 2009-09-03T11:46:56.125826Z 4 mjambon has-props 2484 README file 2007-07-30T20:15:13.834435Z 6d6404efb5fbc9022a3ae6e2be4c68f9 2008-07-04T11:58:10.784200Z 1 mjambon has-props 8215 json-static-0.9.8/META0000664000375200037520000000032411247725620014024 0ustar martinmartinversion = "0.9.8" name = "json-static" description = "statically-typed JSON data" requires = "camlp4 json-wheel" archive(syntax,toploop) = "pa_json_static.cmo" archive(syntax,preprocessor) = "pa_json_static.cmo" json-static-0.9.8/pa_json_static.ml.3100000644000375200037520000005240111247725620017210 0ustar martinmartin(* Conversion between OCaml types and JSON types as provided by the json-wheel library. Author: Martin Jambon Copyright (c) 2007 Burnham Institute for Medical Research Copyright (c) 2008 Martin Jambon All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (* This version was tested successfully with camlp4 3.10.0+beta. The upgrade from 3.09 to 3.10+beta was performed with the help of Nicolas Pouillard. Command that compiles this program: ocamlc -c -pp camlp4orf -I +camlp4 \ pa_json_static_3100beta.ml Before 3.10, it used to be: ocamlc -c -pp 'camlp4o q_MLast.cmo pa_extend.cmo' -I +camlp4 \ pa_json_static.ml Command that works for using this syntax extension when it is present in the current directory (not installed, no ocamlfind). It preprocesses a file that uses the json-static syntax and pretty-prints it to standard OCaml syntax: camlp4o -parser ./pa_json_static_3100beta.cmo -printer o example.ml Before 3.10, it used to be: camlp4o ./pa_json_static.cmo pr_o.cmo example.ml It passes the "make test" stage of the json-static package! *) open Camlp4.PreCast open Printf let check_unique f l = let tbl = Hashtbl.create 50 in List.iter (fun x -> let (_loc, id) = f x in if Hashtbl.mem tbl id then Loc.raise _loc (Failure "this tag or label is not unique") else Hashtbl.add tbl id ()) l let unopt default = function None -> default | Some x -> x let rec optmap f = function [] -> [] | hd :: tl -> match f hd with None -> optmap f tl | Some x -> x :: optmap f tl type field = { field_caml_name : string; field_json_name : string; field_type : t; field_caml_loc : Loc.t; field_json_loc : Loc.t; optional : bool; default : Ast.expr option; is_mutable : bool } and constructor = { cons_caml_name : string; cons_json_name : string; cons_args : t list; cons_caml_loc : Loc.t; cons_json_loc : Loc.t } and type_expr = List of t | Array of t | Option of t | Object of field list | Record of field list | Hashtbl of t | Assoc of t | Tuple of t list | Variant of constructor list | Poly of constructor list | Name of string | String | Bool | Int | Float | Number | Raw | Custom of string and t = Loc.t * type_expr and type_def = { def : t; is_predefined : bool; is_private : bool (* unused at the moment *) } module StringMap = Map.Make (String) let make_typedef _loc names l = let rec convert (_loc, def) = match def with List x -> <:ctyp< list $convert x$ >> | Array x -> <:ctyp< array $convert x$ >> | Option x -> <:ctyp< option $convert x$ >> | Object l -> (* (* Development version post-3.10.0+beta *) let ml = List.fold_right (fun x acc -> <:ctyp< $lid:x.field_caml_name$ : $convert x.field_type$ ; $acc$ >>) l <:ctyp<>> in <:ctyp< < $ml$ > >> in *) let ml = List.fold_right (fun x acc -> let field = <:ctyp< $lid:x.field_caml_name$ : $convert x.field_type$ >> in <:ctyp< $field$ ; $acc$ >>) l <:ctyp<>> in <:ctyp< < $ml$ > >> | Record r -> let l = List.fold_right begin fun x acc -> let _loc = x.field_caml_loc in let t = convert x.field_type in let t = if x.is_mutable then <:ctyp< mutable $t$ >> else t in (* (* Development version post-3.10.0+beta: *) <:ctyp< $lid:x.field_caml_name$ : $t$; $acc$ >> *) let field = <:ctyp< $lid:x.field_caml_name$ : $t$ >> in <:ctyp< $field$; $acc$ >> end r <:ctyp<>> in <:ctyp< { $l$ } >> | Hashtbl x -> <:ctyp< Hashtbl.t string $convert x$ >> | Assoc x -> <:ctyp< list (string * $convert x$) >> | Tuple l -> (* (* Development version post-3.10.0+beta: *) let tl = List.map convert l in <:ctyp< ( $tup:Ast.tySta_of_list tl$ ) >> *) let t = List.fold_right (fun x tup -> <:ctyp< $convert x$ * $tup$ >>) l <:ctyp< >> in <:ctyp< ( $tup:t$ ) >> | Poly l -> let rfl = List.fold_right (fun c acc -> let name = c.cons_caml_name in match c.cons_args with [] -> <:ctyp< `$name$ | $acc$ >> | [x] -> (* (* Development version post-3.10.0+beta: *) <:ctyp< `$name$ of $convert x$ | $acc$ >> *) let case = <:ctyp< `$name$ of $convert x$ >> in <:ctyp< $case$ | $acc$ >> | _ -> assert false) l <:ctyp<>> in <:ctyp< [ = $rfl$ ] >> | Variant v -> let l = List.fold_right (fun x acc -> let cal = List.map convert x.cons_args in let _loc = x.cons_caml_loc in (* (* Development version post-3.10.0+beta: *) <:ctyp< $uid:x.cons_caml_name$ of $list:cal$ | $acc$ >> *) let case = <:ctyp< $uid:x.cons_caml_name$ of $list:cal$ >> in <:ctyp< $case$ | $acc$ >>) v <:ctyp<>> in <:ctyp< [ $l$ ] >> | Name x -> if StringMap.mem x names then <:ctyp< $lid:x$ >> else Loc.raise _loc (Failure ("type name " ^ x ^ " is undefined or not defined in the same \ 'type ... and ...' block")) | String -> <:ctyp< string >> | Bool -> <:ctyp< bool >> | Int -> <:ctyp< int >> | Float -> <:ctyp< float >> | Number -> <:ctyp< float >> | Raw -> <:ctyp< Json_type.t >> | Custom s -> <:ctyp< $uid:s$ . t >> in let l = List.filter (fun (_, x) -> not x.is_predefined) l in match l with [] -> <:str_item< >> | ((_loc, name), x) :: l -> let tdl = let dcl = Ast.TyDcl (_loc, name, [], convert x.def, []) in List.fold_right ( fun ((_loc, name), x) acc -> let dcl = Ast.TyDcl (_loc, name, [], convert x.def, []) in <:ctyp< $dcl$ and $acc$ >> ) l dcl in <:str_item< type $tdl$ >> let numbered_list l = Array.to_list (Array.mapi (fun i x -> (x, "x" ^ string_of_int i)) (Array.of_list l)) let eta_expand = function <:expr< fun [ $_$ ] >> as f -> f | e -> let _loc = Ast.loc_of_expr e in <:expr< fun x -> $e$ x >> let make_ofjson _loc l = let browse _loc f = <:expr< Json_type.Browse.$lid:f$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< $browse _loc "list"$ $convert x$ >> | Array x -> <:expr< fun x -> Array.of_list (($browse _loc "list"$ $convert x$) x) >> | Option x -> <:expr< $browse _loc "optional"$ $convert x$ >> | Object l -> convert_object _loc l | Record r -> convert_record _loc r | Hashtbl x -> <:expr< fun x -> let l = $browse _loc "objekt"$ x in let tbl = Hashtbl.create (List.length l) in do { List.iter (fun (s, x) -> Hashtbl.add tbl s ($convert x$ x)) l; tbl } >> | Assoc x -> <:expr< fun x -> List.map (fun (key, data) -> (key, $convert x$ data)) ($browse _loc "objekt"$ x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun ((_loc, _), name) tl -> <:patt< [ $lid:name$ :: $tl$ ] >>) nl <:patt< [] >> in let el = List.fold_right (fun ((_loc, _) as x, name) acc -> <:expr< $convert x$ $lid:name$, $acc$ >>) nl <:expr<>> in <:expr< fun [ Json_type.Array $pl$ -> ( $tup:el$ ) | Json_type.Array _ as x -> __json_static_error x "wrong number of elements in JSON array" | x -> __json_static_error x "not a JSON array" ] >> | Poly l -> convert_variants (fun _loc name -> <:expr< ` $name$ >>) _loc l | Variant l -> convert_variants (fun _loc name -> <:expr< $uid:name$ >>) _loc l | Name x -> <:expr< $lid: x ^ "_of_json"$ >> | String -> browse _loc "string" | Bool -> browse _loc "bool" | Int -> browse _loc "int" | Float -> browse _loc "float" | Number -> browse _loc "number" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . of_json >> and convert_object _loc l = let pel = convert_object_field_list _loc l in let methods = List.fold_right (fun x acc -> let name = x.field_caml_name in <:class_str_item< method $name$ = $lid:name$ ; $acc$ >>) l <:class_str_item<>> in eval_with_tbl _loc <:expr< let $list:pel$ in object $methods$ end >> and convert_record _loc r = let pel = convert_record_field_list _loc r in eval_with_tbl _loc <:expr< { $list:pel$ } >> and convert_field_list _loc l = List.map (fun { field_caml_name = name; field_json_name = json_name; field_type = x; optional = optional; default = default } -> let e1 = let f = if optional then "fieldx" else "field" in <:expr< Json_type.Browse.$lid:f$ tbl $str:json_name$ >> in let e2 = match default with Some e -> (<:expr< match $e1$ with [ Json_type.Null -> $e$ | x -> $convert x$ x ] >>) | None -> <:expr< $convert x$ $e1$ >> in (name, e2)) l and convert_record_field_list _loc l = List.map (fun (name, e) -> <:rec_binding< $lid:name$ = $e$ >>) (convert_field_list _loc l) and convert_object_field_list _loc l = List.map (fun (name, e) -> <:binding< $lid:name$ = $e$ >>) (convert_field_list _loc l) and convert_variants make_cons _loc l = let l0, l1 = List.partition (fun x -> x.cons_args = []) l in let pwel0 = List.fold_right (fun { cons_caml_name = name; cons_json_name = json_name } acc -> <:match_case< $str:json_name$ -> $make_cons _loc name$ | $acc$ >>) l0 <:match_case<>> in let pwel1 = List.fold_right (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } acc -> let argnames = numbered_list args in let list_patt = List.fold_right (fun (_, s) l -> <:patt< [ $lid:s$ :: $l$ ] >>) argnames <:patt< [] >> in let e = List.fold_left (fun cons (arg, s) -> <:expr< $cons$ ($convert arg$ $lid:s$) >>) (make_cons _loc name) argnames in <:match_case< ($str:json_name$, $list_patt$) -> $e$ | $acc$ >>) l1 <:match_case<>> in let default_case = <:match_case< _ -> __json_static_error x "invalid variant name or \ wrong number of arguments" >> in (<:expr< fun [ Json_type.String s as x -> match s with [ $pwel0$ | $default_case$ ] | Json_type.Array [ Json_type.String s :: ([ _ :: _ ] as args) ] as x -> match (s, args) with [ $pwel1$ | $default_case$ ] | x -> __json_static_error x "not able to read this as \ a variant" ] >>) and eval_with_tbl _loc e = (<:expr< fun x -> let tbl = Json_type.Browse.make_table (Json_type.Browse.objekt x) in $e$ >>) in let error = <:str_item< value __json_static_error obj msg = let m = 400 in let s = Json_io.string_of_json obj in let obj_string = if String.length s > m then String.sub s 0 (m - 4) ^ " ..." else s in Json_type.json_error (msg ^ ":\n" ^ obj_string) >> in let defs = List.fold_right (fun ((_loc, name), x) acc -> (*if x.is_private then acc else*) let fname = name ^ "_of_json" in <:binding< ( $lid:fname$ : Json_type.t -> $lid:name$ ) = $eta_expand (convert x.def)$ and $acc$ >>) l <:binding<>> in <:str_item< $error$; value rec $defs$ >> let make_tojson _loc l = let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in let rec convert (_loc, def) = match def with List x -> <:expr< Json_type.Build.list $convert x$ >> | Array x -> <:expr< fun x -> Json_type.Build.list $convert x$ (Array.to_list x) >> | Option x -> <:expr< Json_type.Build.optional $convert x$ >> | Object l -> convert_field_list (fun name -> <:expr< x#$lid:name$ >>) _loc l | Record r -> convert_field_list (fun name -> <:expr< x.$lid:name$ >>) _loc r | Hashtbl x -> <:expr< fun tbl -> Json_type.Object (Hashtbl.fold (fun key data tl -> [ (key, $convert x$ data) :: tl ]) tbl []) >> | Assoc x -> <:expr< fun x -> Json_type.Object ((List.map (fun (key, data) -> (key, $convert x$ data))) x) >> | Tuple l -> let nl = numbered_list l in let pl = List.fold_right (fun (_, name) acc -> <:patt< $lid:name$, $acc$ >>) nl <:patt<>> in let a = List.fold_right (fun (x, name) tl -> <:expr< [ $convert x$ $lid:name$ :: $tl$ ] >>) nl <:expr< [] >> in <:expr< fun [ ( $tup:pl$ ) -> Json_type.Array $a$ ] >> | Poly l -> let match_cases = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> <:match_case< `$name$ -> Json_type.String $str:json_name$ >> | [x] -> <:match_case< `$name$ arg -> Json_type.Array [ Json_type.String $str:json_name$; $convert x$ arg ] >> | _ -> assert false) l in <:expr< fun [ $list:match_cases$ ] >> | Variant v -> let match_cases = List.map (fun { cons_caml_name = name; cons_json_name = json_name; cons_args = args } -> match args with [] -> <:match_case< $uid:name$ -> Json_type.String $str:json_name$ >> | l -> let args = numbered_list l in let p = List.fold_left (fun cons (_, s) -> <:patt< $cons$ $lid:s$ >>) <:patt< $uid:name$ >> args in let e = List.fold_right (fun (x, s) l -> <:expr< [ $convert x$ $lid:s$ :: $l$ ] >>) args <:expr< [] >> in <:match_case< $p$ -> Json_type.Array [ Json_type.String $str:json_name$ :: $e$ ] >>) v in <:expr< fun [ $list:match_cases$ ] >> | Name x -> <:expr< $lid: "json_of_" ^ x$ >> | String -> build _loc "string" | Bool -> build _loc "bool" | Int -> build _loc "int" | Float -> build _loc "float" | Number -> build _loc "float" | Raw -> <:expr< fun x -> x >> | Custom modul -> <:expr< $uid:modul$ . to_json >> and convert_field_list access _loc l = let pairs = List.fold_right (fun { field_caml_name = name; field_json_name = json_name; field_type = x } tl -> <:expr< [ ( $str:json_name$, $convert x$ $access name$ ) :: $tl$ ] >>) l <:expr< [] >> in <:expr< fun x -> Json_type.Object $pairs$ >> in let defs = List.fold_right (fun ((_loc, name), x) acc -> let fname = "json_of_" ^ name in <:binding< ( $lid:fname$ : $lid:name$ -> Json_type.t ) = $eta_expand (convert x.def)$ and $acc$ >>) l <:binding<>> in <:str_item< value rec $defs$ >> let expand_typedefs _loc l = check_unique (fun (name, _) -> name) l; let names = List.fold_left (fun m (((_loc, name), _) as data) -> StringMap.add name data m) StringMap.empty l in let typedef = make_typedef _loc names l in let ofjson = make_ofjson _loc l in let tojson = make_tojson _loc l in <:str_item< $typedef$; $ofjson$; $tojson$ >> let o2b = function None -> false | _ -> true let is_reserved = let l = [ "json"; "json_type"; "string"; "bool"; "int"; "float"; "number"; "assoc" ] in let tbl = Hashtbl.create 20 in List.iter (fun s -> Hashtbl.add tbl s ()) l; Hashtbl.mem tbl let list_of_opt = function None -> [] | Some x -> [x] let list_of_optlist = function None -> [] | Some x -> x let check_methods l = List.iter (fun x -> if x.is_mutable then Loc.raise x.field_caml_loc (Failure "object fields cannot be made mutable")) l let string_assoc _loc = function (_loc, Tuple [ (_, String); (_, x) ]) -> (_loc, x) | (_, _) -> Loc.raise _loc (Failure "must be of the form (string * ...) assoc") open Syntax let eval_string s = Camlp4.Struct.Token.Eval.string ~strict:() s EXTEND Gram GLOBAL: str_item; str_item: LEVEL "top" [ [ "type"; LIDENT "json"; l = LIST1 type_binding SEP "and" -> expand_typedefs _loc l ] ]; type_binding: [ [ name = [ s = LIDENT -> if is_reserved s then Loc.raise _loc (Failure ("you can't use '" ^ s ^ "' as a type name")) else (_loc, s) ]; "="; p = OPT [ LIDENT "predefined" (* ; priv = OPT "private"*) -> (* priv <> None *) false ]; t = [ t = type_expr -> (t : t) | r = record -> (_loc, Record r) | v = variants -> (_loc, Variant v) ] -> let type_def = match p with None -> { is_predefined = false; is_private = false; def = t } | Some is_private -> { is_predefined = true; is_private = is_private; def = t } in (name, type_def) ] ]; record: [ [ "{"; l = methods; "}" -> l ] ]; variants: [ [ l = LIST1 [ id = [ id = UIDENT -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; typ = OPT [ "of"; x = LIST1 type_expr LEVEL "simple" SEP "*" -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_optlist typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; type_expr: [ "top" [ x = type_expr; "*"; l = LIST1 type_expr LEVEL "simple" SEP "*" -> (_loc, Tuple (x :: l)) ] | "simple" [ x = type_expr; LIDENT "list" -> (_loc, List x) | x = type_expr; LIDENT "array" -> (_loc, Array x) | x = type_expr; LIDENT "option" -> (_loc, Option x) | x = type_expr; LIDENT "assoc" -> (_loc, Assoc (string_assoc _loc x)) | "<"; l = methods; ">" -> check_methods l; (_loc, Object l) | "["; l = polymorphic_variants; "]" -> (_loc, Poly l) | "("; x = type_expr; ")" -> x | "("; LIDENT "string"; ","; x = type_expr; ")"; UIDENT "Hashtbl"; "."; LIDENT "t" -> (_loc, Hashtbl x) | LIDENT "string" -> (_loc, String) | LIDENT "bool" -> (_loc, Bool) | LIDENT "int" -> (_loc, Int) | LIDENT "float" -> (_loc, Float) | LIDENT "number" -> (_loc, Number) | [ UIDENT "Json_type"; "."; LIDENT "json_type" | LIDENT "json_type" ] -> (_loc, Raw) | name = LIDENT -> (_loc, Name name) | module_name = UIDENT; "."; LIDENT "t" -> if module_name = "Json_type" then (_loc, Raw) else (_loc, Custom module_name) ] ]; polymorphic_variants: [ [ l = LIST1 [ "`"; id = [ `(LIDENT id | UIDENT id) -> (_loc, id) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; typ = OPT [ "of"; x = type_expr -> x ] -> let id' = unopt id label in { cons_caml_loc = fst id; cons_caml_name = snd id; cons_json_loc = fst id'; cons_json_name = snd id'; cons_args = list_of_opt typ } ] SEP "|" -> check_unique (fun x -> (x.cons_caml_loc, x.cons_caml_name)) l; check_unique (fun x -> (x.cons_json_loc, x.cons_json_name)) l; l ] ]; methods: [ [ l = LIST0 [ mut = OPT "mutable"; lab = method_label; x = type_expr; default = OPT [ "="; e = expr LEVEL "apply" -> e ] -> let ((id, optional), label) = lab in let id' = unopt id label in { field_caml_loc = fst id; field_caml_name = snd id; field_json_loc = fst id'; field_json_name = snd id'; field_type = x; optional = optional; default = default; is_mutable = (mut <> None) } ] SEP ";" -> check_unique (fun x -> (x.field_caml_loc, x.field_caml_name)) l; check_unique (fun x -> (x.field_json_loc, x.field_json_name)) l; l ] ]; method_label: [ [ id_opt = [ id = LIDENT -> ((_loc, id), false) | "?"; id = LIDENT -> ((_loc, id), true) ]; label = OPT [ s = STRING -> (_loc, eval_string s) ]; ":" -> (id_opt, label) | id = OPTLABEL -> (((_loc, id), true), None) ] ]; END json-static-0.9.8/Makefile0000644000375200037520000000466411247725620015024 0ustar martinmartininclude Camlp4Version VERSION = 0.9.8 export VERSION .PHONY: default all opt init common check test install uninstall .PHONY: clean meta doc archive demo default: all opt all: init common init: echo $$CAMLP4_VERSION echo $$CAMLP4ORF echo $$CAMLP4RF echo $$PR_O echo $$PR_R echo $$PARSER echo $$PRINTER echo '# 1 "pa_json_static.ml.$(CAMLP4_VERSION)"' > pa_json_static.ml cat pa_json_static.ml.$(CAMLP4_VERSION) >> pa_json_static.ml ln -sf pa_json_static.ml.annot pa_json_static.annot common: ocamlc -c -dtypes \ -pp '$(CAMLP4ORF) -loc _loc' \ -I +camlp4 pa_json_static.ml demo: yahoo ./yahoo "Nelson Mandela" test: check check: camlp4o -I . $(PR_O) $(PARSER) pa_json_static.cmo check.ml -o check.ppo # ocamlfind ocamlopt -c -package json-wheel -impl check.ppo ocamlfind ocamlc -i -package json-wheel \ -pp 'camlp4o -I . $(PARSER) pa_json_static.cmo' check.ml \ > check.mli.auto ocamlfind ocamlopt -o check -package json-wheel -linkpkg \ -pp 'camlp4o -I . $(PARSER) pa_json_static.cmo' \ check.ml ./check install: META ocamlfind install json-static META \ pa_json_static.cmi pa_json_static.cmo META: META.template Makefile echo 'version = "$(VERSION)"' > META cat META.template >> META uninstall: ocamlfind remove json-static clean: rm -f *.ppo *.ppr *.cmo *.cmi *.o *.cmx *.ast *~ *.auto *.annot \ check yahoo yahoo.ml.html test_typedefs.json \ pa_json_static.ml yahoo: yahoo.ml ocamlfind ocamlopt -o yahoo yahoo.ml -dtypes -linkpkg \ -package json-static,netclient -syntax camlp4o archive: rm -rf /tmp/json-static /tmp/json-static-$(VERSION) && \ cp -r . /tmp/json-static && \ cd /tmp/json-static && \ $(MAKE) clean && \ rm -f *~ json-static*.tar* && \ cd /tmp && cp -r json-static json-static-$(VERSION) && \ tar czf json-static.tar.gz json-static && \ tar cjf json-static.tar.bz2 json-static && \ tar czf json-static-$(VERSION).tar.gz json-static-$(VERSION) && \ tar cjf json-static-$(VERSION).tar.bz2 json-static-$(VERSION) mv /tmp/json-static.tar.gz /tmp/json-static.tar.bz2 . mv /tmp/json-static-$(VERSION).tar.gz /tmp/json-static-$(VERSION).tar.bz2 . cp json-static.tar.gz json-static.tar.bz2 $$WWW/ cp json-static-$(VERSION).tar.gz json-static-$(VERSION).tar.bz2 $$WWW/ cp LICENSE $$WWW/json-static-license.txt cp README $$WWW/json-static-readme.txt cp Changes $$WWW/json-static-changes.txt cp yahoo.ml $$WWW/ echo 'let json_static_version = "$(VERSION)"' \ > $$WWW/json-static-version.ml json-static-0.9.8/check.ml0000644000375200037520000000102111247725620014753 0ustar martinmartin(* Initialization commands to type in the ocaml toplevel: #use "topfind";; #camlp4o;; #require "json-wheel";; #load "pa_json_static.cmo";; *) (**************** Miscellaneous tests (should compile fine) ************) type coord = { x : int; y : int; z : int } type json variant = A | B of coord | C of float * variant | D of (bool * int option) and coord = predefined { x : int; y : int; z : int } type json a = b list and b = int type json c = (string * d * d) list and d = [ `A ] json-static-0.9.8/META.template0000644000375200037520000000030211247725620015630 0ustar martinmartinname = "json-static" description = "statically-typed JSON data" requires = "camlp4 json-wheel" archive(syntax,toploop) = "pa_json_static.cmo" archive(syntax,preprocessor) = "pa_json_static.cmo" json-static-0.9.8/Changes0000644000375200037520000000170111247725620014644 0ustar martinmartin2009-09-03: 0.9.8 * Fixed bug leading "predefined" to be ignored if first in a group of type definitions. 2009-08-13: 0.9.7 * Fix allowing toplevel use 2008-02-04: 0.9.6 2007-04-02: 0.9.5 Added support for "the new camlp4" (3.10.0+beta) 2007-03-04: 0.9.4 * Fixed bug that occured with definitions like (string * int * int) list saying that an assoc type was expected. 2007-02-22: 0.9.3 * Added support for records and classic variants, possibly predefined. * Fixed bug "This kind of expression is not allowed as right-hand side of `let rec'" which occurred in cases like type json a = b list and b = int * Slightly improved conversion to polymorphic variants 2007-01-25: 0.9.2 Added support for association lists built from objects ("assoc") 2007-01-24: 0.9.1 Added support for optional object fields and default values 2007-01-19: 0.9.0 "Preview release"