Commits

camlspotter committed 6a840e0

rename

Comments (0)

Files changed (24)

json-tc-custom/Changes

-
-2009-12-3: 0.9.0
-       Initial release of json-static-0.9.8 ported over to use type-conv

json-tc-custom/LICENSE

-Copyright (c) 2007 Burnham Institute for Medical Research
-Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
-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-tc-custom/Makefile

-.PHONY: all test clean
-
-# SUDO ?= sudo
-
-all:
-	@cd lib && $(MAKE)
-
-test: all
-	@cd lib_test && $(MAKE)
-
-clean:
-	@cd lib && $(MAKE) clean
-	@cd lib_test && $(MAKE) clean
-
-install:
-	@cd lib && $(SUDO) $(MAKE) install
-
-uninstall:
-	@cd lib && $(SUDO) $(MAKE) uninstall
-
-reinstall:
-	-$(MAKE) uninstall
-	$(MAKE) install

json-tc-custom/OMakefile

-SOURCES[]=
-  lib/META.template
-  lib/Makefile
-  lib/pa_json_tc.ml
-
-$(Installed json-tc-custom): $(Installed type-conv) $(SOURCES)
-  (cd lib/; make uninstall all install; spotinstall json-tc-custom)
-  CreateInstalled(json-tc-custom, $(find $(OCAMLFIND_DESTDIR)$(DIRSEP)json-tc-custom -f {}))
-
-clean:
-  (cd lib; make clean)

json-tc-custom/README

-                          json-tc
-
-Introduction
-============
-
-json-tc 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 point = < x: float; y: float > with json
-
-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_tc.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-tc.syntax
-
-# link
-ocamlfind ocamlopt -o yourprog yourfile.cmx -linkpkg -package json-tc.syntax
-
-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
-"with json" is placed after the type definition, as:
-
-  type t = int * float with json
-                       ^^^^^^^^^
-
-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 a = b
-  and b = int list with json
-
-But the following doesn't work:
-
-  type b = int list with json
-
-  type a = b with json (* b is unknown to the preprocessor *)
-
-
-Example 1
-=========
-
-The following definition is correct:
-
-type point = < x: number; y: number >
-and coords = point array with json
-
-It can successfully load the following JSON data:
-
-[ { "x": 1, "y": 0.5 },
-  { "x": 0, "y": 0.3333333 } ]
-
-
-Full example:
-
-(* File example1.ml *)
-
-type point = < x: number; y: number >
-and coords = point array with json
-
-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-tc -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 colors = [ `Black 
-                   | `White 
-                   | `Rgb of (float * float * float)
-                   | `Any "*" ] list with json
-
-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-tc -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.
-
-
-Credits
-=======
-
-json-tc is based on the json-static/json-wheel libraries by Martin
-Jambon, and converted to use the type-conv library so that it can
-be used alongside other camlp4 syntax extensions.

json-tc-custom/README.custom.rst

-==========================================
-JSON type-conv custom
-==========================================
-
-caml field and CAML constructor names
-==========================================
-
-To work with Json names which are OCaml registered keywords like "type",
-uppercase field names, and lowercase tag names, a special handling
-is introduced for OCaml record fields and constructors which start 
-with "caml_" and "CAML_" respectively::
-
-  type t = CAML_text with json (* in Json, not "CAML_text" but "text" *)
-
-  type r = { caml_type : t } with json (* in Json, not "caml_type" but "type" *)
-
-optional type
-==========================================
-
-Data type name "optional" in OCaml record field type is specially handled. 
-It works as the option type, but the field can be really optional. The field
-need not to exist in Json fields at Json => OCaml translation.
-
-  type 'a optional = 'a option (* You need to declare this alias *)
-
-  type r = { id : Id.t;  (* mandatory field *)
-             source_url : string optional; (* if not exists in Json, None in OCaml *)
-           } with json
-
-  CR jfuruse: No OCaml => Json handling of optional is considered yet.

json-tc-custom/lib/META.template

-name = "json-tc"
-description = "statically-typed JSON data using type-conv"
-
-package "syntax" (
-  requires = "camlp4 json-wheel type-conv"
-  archive(syntax, preprocessor) = "pa_json_tc.cmo"
-  archive(syntax, toploop) = "pa_json_tc.cmo"
-)

json-tc-custom/lib/Makefile

-VERSION = 0.9.0
-export VERSION
-
-CAMLP4ORF ?= camlp4orf
-
-.PHONY: default all opt init common check test install uninstall
-.PHONY: clean meta doc archive demo
-
-default: all init
-all: init common
-
-all:
-	ocamlfind ocamlc -package type-conv -c -pp "$(CAMLP4ORF)" -annot -g -I +camlp4 pa_json_tc.ml
-
-install: META
-	ocamlfind install json-tc-custom META pa_json_tc.cmi pa_json_tc.cmo
-
-META: META.template Makefile
-	echo 'version = "$(VERSION)"' > META
-	cat META.template >> META
-
-uninstall:
-	ocamlfind remove json-tc-custom
-
-clean:
-	rm -f *.ppo *.ppr *.cmo *.cmi *.cm* *.o *.cmx *.ast *~ *.auto *.annot META

json-tc-custom/lib/pa_json_tc.ml

-(*
-  Conversion between OCaml types and JSON types as provided by the json-wheel
-  library. 
-  
-  Author: Martin Jambon <martin_jambon@emailuser.net>
-
-Copyright (c) 2007 Burnham Institute for Medical Research
-Copyright (c) 2008 Martin Jambon
-Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
-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
-  | Int32
-  | Int64
-  | Char
-  | Unit
-  | Float
-  | Number
-  | Raw
-  | Custom of string
-
-and t = Loc.t * type_expr
-
-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 >>
-      | Unit -> <:expr< let browse_unit _ = () in browse_unit >>
-      | Char -> <:expr< 
-         let browse_char x = match $browse _loc "string"$ x with [
-           "" -> raise (Json_type.Json_error "empty character")
-         | x  -> x.[0] ] 
-         in browse_char >>
-      | Int32 -> <:expr<
-         let browse_int32 x = Int32.of_float ($browse _loc "number"$ x) in
-         browse_int32 >>
-      | Int64 -> <:expr<
-         let browse_int64 x = Int64.of_float ($browse _loc "number"$ x) in
-         browse_int64 >>
-
-   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)$ 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"
-      | Int32 -> <:expr< let build_int32 x = Json_type.Build.float (Int32.to_float x) in build_int32 >>
-      | Int64 -> <:expr< let build_int64 x = Json_type.Build.float (Int64.to_float x) in build_int64 >>
-      | Unit -> <:expr< let build_unit () = Json_type.Build.int 0 in build_unit >>
-      | Char -> <:expr< let build_char x = Json_type.Build.string (String.make 1 x) in build_char >>
-      | 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)$ and $acc$ >>)
-      l <:binding<>> in
-  <:str_item< value rec $defs$ >>
-
-
-let expand_typedefs _loc l =
-  check_unique (fun (name, _) -> name) l;
-  let ofjson = make_ofjson _loc l in
-  let tojson = make_tojson _loc l in
-  <:str_item< $ofjson$; $tojson$ >>
-
-let type_fail ctyp msg =
-  Loc.raise (Ast.loc_of_ctyp ctyp) (Failure msg)
-
-let rec process_tds skips tds =
-  let rec fn ty =
-    match ty with
-    |Ast.TyAnd (_loc, tyl, tyr) ->
-       fn tyl @ (fn tyr)
-    |Ast.TyDcl (_loc, id, _, ty, []) ->
-       if List.mem id skips then [] else
-       [ (_loc, id ) , (_loc, process_td _loc ty) ]
-    | other -> type_fail other "process_tds: unexpected AST"
-   in fn tds
-
-and process_fields _loc cs =
-  let rec fn = function
-    | <:ctyp< $t1$; $t2$ >> -> fn t1 @ (fn t2)
-    | <:ctyp< $lid:id$ : mutable $t$ >> -> fnt ~mut:true ~id ~t
-    | <:ctyp< $lid:id$ : $t$ >> ->  fnt ~mut:false ~id ~t
-    | other -> type_fail other "process_fields: unexpected AST"
-  and fnt ~mut ~id ~t =
-    let field_json_name = if try String.sub id 0 5 = "caml_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
-    let optional, t = match t with
-      | <:ctyp< optional $t$ >> -> true, <:ctyp< option $t$ >>
-      | _ -> false, t
-    in
-    [ { field_caml_name = id; field_json_name;
-        field_type = (_loc, process_td _loc t);
-        field_caml_loc = _loc; field_json_loc = _loc;
-        optional; default=None; is_mutable = mut } ]
-  in fn cs
-
-and process_constructor _loc rf =
-  List.map (function
-    | <:ctyp< `$uid:id$ of $t$ >> 
-    | <:ctyp< $uid:id$ of $t$ >> ->
-       
-       let cons_args = List.map (fun x -> _loc, process_td _loc x) (Ast.list_of_ctyp t []) in
-       let cons_json_name = if try String.sub id 0 5 = "CAML_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
-       { cons_caml_name=id; cons_json_name; cons_caml_loc=_loc;
-         cons_json_loc=_loc; cons_args=cons_args }
-    | <:ctyp< `$uid:id$ >> 
-    | <:ctyp< $uid:id$ >> ->
-       let cons_json_name = if try String.sub id 0 5 = "CAML_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
-       { cons_caml_name=id; cons_json_name; cons_caml_loc=_loc;
-         cons_json_loc=_loc; cons_args=[] }
-    | other -> type_fail other "process_constructor: unexpected AST"
-  ) (Ast.list_of_ctyp rf [])
- 
-and process_td _loc = function
- | <:ctyp< string >> -> String
- | <:ctyp< int >> -> Int
- | <:ctyp< float >> -> Float
- | <:ctyp< bool >> -> Bool
- | <:ctyp< int32 >> -> Int32
- | <:ctyp< int64 >> -> Int64
- | <:ctyp< unit >> -> Unit
- | <:ctyp< char >> -> Char
-
- | <:ctyp< Hashtbl.t string $t$ >> -> Hashtbl (_loc, process_td _loc t)
- | <:ctyp< list ( string * $t$ ) >> -> Assoc (_loc, process_td _loc t)
-
- | <:ctyp< option $t$ >> -> Option (_loc, process_td _loc t)
- | <:ctyp< list $t$ >> -> List (_loc, process_td _loc t)
- | <:ctyp< array $t$ >> -> Array (_loc, process_td _loc t)
-
- | <:ctyp< < $cs$ > >> -> Object (process_fields _loc cs)
- | <:ctyp< { $cs$ } >> -> Record (process_fields _loc cs)
-
- | <:ctyp< [< $rf$ ] >> 
- | <:ctyp< [> $rf$ ] >>
- | <:ctyp< [= $rf$ ] >> -> Poly (process_constructor _loc rf)
- | <:ctyp< [ $rf$ ] >> -> Variant (process_constructor _loc rf)
- | <:ctyp< ( $tup:tp$ ) >> -> 
-   let tps = List.map 
-     (fun t -> _loc, process_td _loc t) 
-       (Ast.list_of_ctyp tp []) in
-   Tuple tps
-
- | <:ctyp< $uid:id$.t >> -> Custom id
- | <:ctyp< $lid:id$ >> -> Name id
- | other -> type_fail other "unknown_type"
-
-let json_parms = Gram.Entry.mk "json_parms"
-EXTEND Gram
-
-GLOBAL: json_parms;
-json_svars: [[ l = LIST1 [ `LIDENT(x) -> x ] SEP "," -> l ]];
-
-json_param: [[ 
-  "skip"; ":" ; x = json_svars -> `Skip x
-]];
-
-json_parms: [
-  [ l = LIST0 [ json_param ] SEP ";" -> l ]
-];
-
-END
-
-open Pa_type_conv
-let _ =
-  add_generator_with_arg "json" json_parms
-   (fun tds args -> 
-     let _loc = Loc.ghost in
-     let ptd = match args with
-     | None -> process_tds [] tds
-     | Some x -> 
-         let skips = List.fold_left (fun a -> function | `Skip x -> a @ x) [] x in
-         process_tds skips tds in
-     <:str_item< $expand_typedefs _loc ptd$ >>)
-

json-tc-custom/lib_test/Makefile

-CAMLP4ORF ?= camlp4orf
-
-test: check
-check:
-	ocamlfind ocamlc -package json-wheel -linkpkg -o $@ \
-	  -pp "$(CAMLP4ORF) -I `ocamlfind query type-conv` -I ../lib pa_type_conv.cma pa_json_tc.cmo" $@.ml
-	./$@
-
-clean:
-	rm -f *.ppo *.ppr *.cmo *.cmi *.o *.cmx *.ast *~ *.auto *.annot check

json-tc-custom/lib_test/check.ml

-(* test file for the type-conv version, compile with "make jtc-check_tc" *)
-
-type x = [ `One | `Two ]
-and y = Three of int | Four of (char * int32 * int64)
-and t = { 
-  foo: string;
-  bar: int;
-  wha: bool;
-  bla: string * int * unit;
-  pol: x;
-  vat: y; 
-  h: (string, int64) Hashtbl.t;
-  a: (string * string) list
-} with json
-
-type o = <
-  foo: string;
-  bar: int
-> and
-odd = {
-  fn: int -> int;
-  fn2: unit
-} with json(skip:odd)
-
-let _ = 
-  let h = Hashtbl.create 1 in 
-  Hashtbl.add h "a" 1L;
-  Hashtbl.add h "b" 2L;
-  let a = [ "one", "ONE"; "two","TWO"; "three","THREE" ] in
-  let t = { foo="foo"; bar=10; wha=true; bla=("foo1",5,()); pol=`Two; vat=(Four ('x',500l,6000L)); h=h; a=a } in
-  let json_string = Json_io.string_of_json (json_of_t t) in
-  let _ = t_of_json (Json_io.json_of_string json_string) in
-  prerr_endline json_string;
-  let o = object method foo="foo" method bar=1 end in
-  let json_string = Json_io.string_of_json (json_of_o o) in
-  let json_o = o_of_json (Json_io.json_of_string json_string) in
-  assert (json_o#foo = o#foo);
-  assert (json_o#bar = o#bar);
-  prerr_endline json_string
Add a comment to this file

json-tc-custom/ocaml-json-tc-2011-04-27.tar.gz

Binary file removed.

ocaml-json-tc-custom/Changes

+
+2009-12-3: 0.9.0
+       Initial release of json-static-0.9.8 ported over to use type-conv

ocaml-json-tc-custom/LICENSE

+Copyright (c) 2007 Burnham Institute for Medical Research
+Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
+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.

ocaml-json-tc-custom/Makefile

+.PHONY: all test clean
+
+# SUDO ?= sudo
+
+all:
+	@cd lib && $(MAKE)
+
+test: all
+	@cd lib_test && $(MAKE)
+
+clean:
+	@cd lib && $(MAKE) clean
+	@cd lib_test && $(MAKE) clean
+
+install:
+	@cd lib && $(SUDO) $(MAKE) install
+
+uninstall:
+	@cd lib && $(SUDO) $(MAKE) uninstall
+
+reinstall:
+	-$(MAKE) uninstall
+	$(MAKE) install

ocaml-json-tc-custom/OMakefile

+SOURCES[]=
+  lib/META.template
+  lib/Makefile
+  lib/pa_json_tc.ml
+
+$(Installed json-tc-custom): $(Installed type-conv) $(SOURCES)
+  (cd lib/; make uninstall all install; spotinstall json-tc-custom)
+  CreateInstalled(json-tc-custom, $(find $(OCAMLFIND_DESTDIR)$(DIRSEP)json-tc-custom -f {}))
+
+clean:
+  (cd lib; make clean)

ocaml-json-tc-custom/README

+                          json-tc
+
+Introduction
+============
+
+json-tc 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 point = < x: float; y: float > with json
+
+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_tc.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-tc.syntax
+
+# link
+ocamlfind ocamlopt -o yourprog yourfile.cmx -linkpkg -package json-tc.syntax
+
+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
+"with json" is placed after the type definition, as:
+
+  type t = int * float with json
+                       ^^^^^^^^^
+
+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 a = b
+  and b = int list with json
+
+But the following doesn't work:
+
+  type b = int list with json
+
+  type a = b with json (* b is unknown to the preprocessor *)
+
+
+Example 1
+=========
+
+The following definition is correct:
+
+type point = < x: number; y: number >
+and coords = point array with json
+
+It can successfully load the following JSON data:
+
+[ { "x": 1, "y": 0.5 },
+  { "x": 0, "y": 0.3333333 } ]
+
+
+Full example:
+
+(* File example1.ml *)
+
+type point = < x: number; y: number >
+and coords = point array with json
+
+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-tc -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 colors = [ `Black 
+                   | `White 
+                   | `Rgb of (float * float * float)
+                   | `Any "*" ] list with json
+
+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-tc -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.
+
+
+Credits
+=======
+
+json-tc is based on the json-static/json-wheel libraries by Martin
+Jambon, and converted to use the type-conv library so that it can
+be used alongside other camlp4 syntax extensions.

ocaml-json-tc-custom/README.custom.rst

+==========================================
+JSON type-conv custom
+==========================================
+
+caml field and CAML constructor names
+==========================================
+
+To work with Json names which are OCaml registered keywords like "type",
+uppercase field names, and lowercase tag names, a special handling
+is introduced for OCaml record fields and constructors which start 
+with "caml_" and "CAML_" respectively::
+
+  type t = CAML_text with json (* in Json, not "CAML_text" but "text" *)
+
+  type r = { caml_type : t } with json (* in Json, not "caml_type" but "type" *)
+
+optional type
+==========================================
+
+Data type name "optional" in OCaml record field type is specially handled. 
+It works as the option type, but the field can be really optional. The field
+need not to exist in Json fields at Json => OCaml translation.
+
+  type 'a optional = 'a option (* You need to declare this alias *)
+
+  type r = { id : Id.t;  (* mandatory field *)
+             source_url : string optional; (* if not exists in Json, None in OCaml *)
+           } with json
+
+  CR jfuruse: No OCaml => Json handling of optional is considered yet.

ocaml-json-tc-custom/lib/META.template

+name = "json-tc"
+description = "statically-typed JSON data using type-conv"
+
+package "syntax" (
+  requires = "camlp4 json-wheel type-conv"
+  archive(syntax, preprocessor) = "pa_json_tc.cmo"
+  archive(syntax, toploop) = "pa_json_tc.cmo"
+)

ocaml-json-tc-custom/lib/Makefile

+VERSION = 0.9.0
+export VERSION
+
+CAMLP4ORF ?= camlp4orf
+
+.PHONY: default all opt init common check test install uninstall
+.PHONY: clean meta doc archive demo
+
+default: all init
+all: init common
+
+all:
+	ocamlfind ocamlc -package type-conv -c -pp "$(CAMLP4ORF)" -annot -g -I +camlp4 pa_json_tc.ml
+
+install: META
+	ocamlfind install json-tc-custom META pa_json_tc.cmi pa_json_tc.cmo
+
+META: META.template Makefile
+	echo 'version = "$(VERSION)"' > META
+	cat META.template >> META
+
+uninstall:
+	ocamlfind remove json-tc-custom
+
+clean:
+	rm -f *.ppo *.ppr *.cmo *.cmi *.cm* *.o *.cmx *.ast *~ *.auto *.annot META

ocaml-json-tc-custom/lib/pa_json_tc.ml

+(*
+  Conversion between OCaml types and JSON types as provided by the json-wheel
+  library. 
+  
+  Author: Martin Jambon <martin_jambon@emailuser.net>
+
+Copyright (c) 2007 Burnham Institute for Medical Research
+Copyright (c) 2008 Martin Jambon
+Copyright (c) 2009 Anil Madhavapeddy <anil@recoil.org>
+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
+  | Int32
+  | Int64
+  | Char
+  | Unit
+  | Float
+  | Number
+  | Raw
+  | Custom of string
+
+and t = Loc.t * type_expr
+
+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 >>
+      | Unit -> <:expr< let browse_unit _ = () in browse_unit >>
+      | Char -> <:expr< 
+         let browse_char x = match $browse _loc "string"$ x with [
+           "" -> raise (Json_type.Json_error "empty character")
+         | x  -> x.[0] ] 
+         in browse_char >>
+      | Int32 -> <:expr<
+         let browse_int32 x = Int32.of_float ($browse _loc "number"$ x) in
+         browse_int32 >>
+      | Int64 -> <:expr<
+         let browse_int64 x = Int64.of_float ($browse _loc "number"$ x) in
+         browse_int64 >>
+
+   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)$ 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"
+      | Int32 -> <:expr< let build_int32 x = Json_type.Build.float (Int32.to_float x) in build_int32 >>
+      | Int64 -> <:expr< let build_int64 x = Json_type.Build.float (Int64.to_float x) in build_int64 >>
+      | Unit -> <:expr< let build_unit () = Json_type.Build.int 0 in build_unit >>
+      | Char -> <:expr< let build_char x = Json_type.Build.string (String.make 1 x) in build_char >>
+      | 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)$ and $acc$ >>)
+      l <:binding<>> in
+  <:str_item< value rec $defs$ >>
+
+
+let expand_typedefs _loc l =
+  check_unique (fun (name, _) -> name) l;
+  let ofjson = make_ofjson _loc l in
+  let tojson = make_tojson _loc l in
+  <:str_item< $ofjson$; $tojson$ >>
+
+let type_fail ctyp msg =
+  Loc.raise (Ast.loc_of_ctyp ctyp) (Failure msg)
+
+let rec process_tds skips tds =
+  let rec fn ty =
+    match ty with
+    |Ast.TyAnd (_loc, tyl, tyr) ->
+       fn tyl @ (fn tyr)
+    |Ast.TyDcl (_loc, id, _, ty, []) ->
+       if List.mem id skips then [] else
+       [ (_loc, id ) , (_loc, process_td _loc ty) ]
+    | other -> type_fail other "process_tds: unexpected AST"
+   in fn tds
+
+and process_fields _loc cs =
+  let rec fn = function
+    | <:ctyp< $t1$; $t2$ >> -> fn t1 @ (fn t2)
+    | <:ctyp< $lid:id$ : mutable $t$ >> -> fnt ~mut:true ~id ~t
+    | <:ctyp< $lid:id$ : $t$ >> ->  fnt ~mut:false ~id ~t
+    | other -> type_fail other "process_fields: unexpected AST"
+  and fnt ~mut ~id ~t =
+    let field_json_name = if try String.sub id 0 5 = "caml_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
+    let optional, t = match t with
+      | <:ctyp< optional $t$ >> -> true, <:ctyp< option $t$ >>
+      | _ -> false, t
+    in
+    [ { field_caml_name = id; field_json_name;
+        field_type = (_loc, process_td _loc t);
+        field_caml_loc = _loc; field_json_loc = _loc;
+        optional; default=None; is_mutable = mut } ]
+  in fn cs
+
+and process_constructor _loc rf =
+  List.map (function
+    | <:ctyp< `$uid:id$ of $t$ >> 
+    | <:ctyp< $uid:id$ of $t$ >> ->
+       
+       let cons_args = List.map (fun x -> _loc, process_td _loc x) (Ast.list_of_ctyp t []) in
+       let cons_json_name = if try String.sub id 0 5 = "CAML_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
+       { cons_caml_name=id; cons_json_name; cons_caml_loc=_loc;
+         cons_json_loc=_loc; cons_args=cons_args }
+    | <:ctyp< `$uid:id$ >> 
+    | <:ctyp< $uid:id$ >> ->
+       let cons_json_name = if try String.sub id 0 5 = "CAML_" with _ -> false then String.sub id 5 (String.length id - 5) else id in
+       { cons_caml_name=id; cons_json_name; cons_caml_loc=_loc;
+         cons_json_loc=_loc; cons_args=[] }
+    | other -> type_fail other "process_constructor: unexpected AST"
+  ) (Ast.list_of_ctyp rf [])
+ 
+and process_td _loc = function
+ | <:ctyp< string >> -> String
+ | <:ctyp< int >> -> Int
+ | <:ctyp< float >> -> Float
+ | <:ctyp< bool >> -> Bool
+ | <:ctyp< int32 >> -> Int32
+ | <:ctyp< int64 >> -> Int64
+ | <:ctyp< unit >> -> Unit
+ | <:ctyp< char >> -> Char
+
+ | <:ctyp< Hashtbl.t string $t$ >> -> Hashtbl (_loc, process_td _loc t)
+ | <:ctyp< list ( string * $t$ ) >> -> Assoc (_loc, process_td _loc t)
+
+ | <:ctyp< option $t$ >> -> Option (_loc, process_td _loc t)
+ | <:ctyp< list $t$ >> -> List (_loc, process_td _loc t)
+ | <:ctyp< array $t$ >> -> Array (_loc, process_td _loc t)
+
+ | <:ctyp< < $cs$ > >> -> Object (process_fields _loc cs)
+ | <:ctyp< { $cs$ } >> -> Record (process_fields _loc cs)
+
+ | <:ctyp< [< $rf$ ] >> 
+ | <:ctyp< [> $rf$ ] >>
+ | <:ctyp< [= $rf$ ] >> -> Poly (process_constructor _loc rf)
+ | <:ctyp< [ $rf$ ] >> -> Variant (process_constructor _loc rf)
+ | <:ctyp< ( $tup:tp$ ) >> -> 
+   let tps = List.map 
+     (fun t -> _loc, process_td _loc t) 
+       (Ast.list_of_ctyp tp []) in
+   Tuple tps
+
+ | <:ctyp< $uid:id$.t >> -> Custom id
+ | <:ctyp< $lid:id$ >> -> Name id
+ | other -> type_fail other "unknown_type"
+
+let json_parms = Gram.Entry.mk "json_parms"
+EXTEND Gram
+
+GLOBAL: json_parms;
+json_svars: [[ l = LIST1 [ `LIDENT(x) -> x ] SEP "," -> l ]];
+
+json_param: [[ 
+  "skip"; ":" ; x = json_svars -> `Skip x
+]];
+
+json_parms: [
+  [ l = LIST0 [ json_param ] SEP ";" -> l ]
+];
+
+END
+
+open Pa_type_conv
+let _ =
+  add_generator_with_arg "json" json_parms
+   (fun tds args -> 
+     let _loc = Loc.ghost in
+     let ptd = match args with
+     | None -> process_tds [] tds
+     | Some x -> 
+         let skips = List.fold_left (fun a -> function | `Skip x -> a @ x) [] x in
+         process_tds skips tds in
+     <:str_item< $expand_typedefs _loc ptd$ >>)
+

ocaml-json-tc-custom/lib_test/Makefile

+CAMLP4ORF ?= camlp4orf
+
+test: check
+check:
+	ocamlfind ocamlc -package json-wheel -linkpkg -o $@ \
+	  -pp "$(CAMLP4ORF) -I `ocamlfind query type-conv` -I ../lib pa_type_conv.cma pa_json_tc.cmo" $@.ml
+	./$@
+
+clean:
+	rm -f *.ppo *.ppr *.cmo *.cmi *.o *.cmx *.ast *~ *.auto *.annot check

ocaml-json-tc-custom/lib_test/check.ml

+(* test file for the type-conv version, compile with "make jtc-check_tc" *)
+
+type x = [ `One | `Two ]
+and y = Three of int | Four of (char * int32 * int64)
+and t = { 
+  foo: string;
+  bar: int;
+  wha: bool;
+  bla: string * int * unit;
+  pol: x;
+  vat: y; 
+  h: (string, int64) Hashtbl.t;
+  a: (string * string) list
+} with json
+
+type o = <
+  foo: string;
+  bar: int
+> and
+odd = {
+  fn: int -> int;
+  fn2: unit
+} with json(skip:odd)
+
+let _ = 
+  let h = Hashtbl.create 1 in 
+  Hashtbl.add h "a" 1L;
+  Hashtbl.add h "b" 2L;
+  let a = [ "one", "ONE"; "two","TWO"; "three","THREE" ] in
+  let t = { foo="foo"; bar=10; wha=true; bla=("foo1",5,()); pol=`Two; vat=(Four ('x',500l,6000L)); h=h; a=a } in
+  let json_string = Json_io.string_of_json (json_of_t t) in
+  let _ = t_of_json (Json_io.json_of_string json_string) in
+  prerr_endline json_string;
+  let o = object method foo="foo" method bar=1 end in
+  let json_string = Json_io.string_of_json (json_of_o o) in
+  let json_o = o_of_json (Json_io.json_of_string json_string) in
+  assert (json_o#foo = o#foo);
+  assert (json_o#bar = o#bar);
+  prerr_endline json_string
Add a comment to this file

ocaml-json-tc-custom/ocaml-json-tc-2011-04-27.tar.gz

Binary file added.

Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.