├── .gitignore ├── .ocp-indent ├── INSTALL ├── LICENSE ├── Makefile ├── README.md ├── TODO.md ├── VERSION ├── atdgen-cppo ├── LICENSE ├── README.md ├── atdgen-cppo ├── cppo-json ├── example.ml └── jbuild ├── atdgen.opam ├── bin ├── ag_main.ml └── jbuild ├── example ├── Makefile ├── README ├── example.sh ├── format_v1.atd ├── format_v2.atd └── upgrade_demo.ml ├── src ├── .gitignore ├── ag_biniou.ml ├── ag_doc.ml ├── ag_doc.mli ├── ag_doc_lexer.mll ├── ag_error.ml ├── ag_indent.ml ├── ag_json.ml ├── ag_json.mli ├── ag_mapping.ml ├── ag_ob_emit.ml ├── ag_ob_mapping.ml ├── ag_ob_run.ml ├── ag_ob_spe.ml ├── ag_ocaml.ml ├── ag_ocaml.mli ├── ag_oj_emit.ml ├── ag_oj_emit.mli ├── ag_oj_mapping.ml ├── ag_oj_run.ml ├── ag_ov_emit.ml ├── ag_ov_mapping.ml ├── ag_ov_run.ml ├── ag_ox_emit.ml ├── ag_ox_emit.mli ├── ag_string_match.ml ├── ag_string_match.mli ├── ag_util.ml ├── ag_util.mli ├── ag_validate.ml ├── ag_xb_emit.ml └── jbuild ├── test ├── .gitignore ├── benchmark.ml ├── jbuild ├── test.atd ├── test2.atd ├── test3j.atd ├── test4.atd ├── test5.atd ├── test_atdgen_main.ml ├── test_atdgen_type_conv.ml ├── test_lib.ml └── test_type_conv.atd └── util └── recompile-deps /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.cmi 3 | *.cmo 4 | *.cmx 5 | *.cma 6 | *.cmxa 7 | *.cmxs 8 | *.a 9 | *.o 10 | *.annot 11 | *.run 12 | *.opt 13 | *.exe 14 | _build 15 | .merlin 16 | *.install -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | # See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more 2 | 3 | # Indent for clauses inside a pattern-match (after the arrow): 4 | # match foo with 5 | # | _ -> 6 | # ^^^^bar 7 | # the default is 2, which aligns the pattern and the expression 8 | match_clause = 4 9 | 10 | # When nesting expressions on the same line, their indentation are in 11 | # some cases stacked, so that it remains correct if you close them one 12 | # at a line. This may lead to large indents in complex code though, so 13 | # this parameter can be used to set a maximum value. Note that it only 14 | # affects indentation after function arrows and opening parens at end 15 | # of line. 16 | # 17 | # for example (left: `none`; right: `4`) 18 | # let f = g (h (i (fun x -> # let f = g (h (i (fun x -> 19 | # x) # x) 20 | # ) # ) 21 | # ) # ) 22 | max_indent = 2 23 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | 2 | Installation instructions for atdgen 3 | ==================================== 4 | 5 | 6 | Godi makes the installation process straightforward. Simply install the 7 | godi-atdgen package using `godi_console'. Dependencies will be selected 8 | and installed automatically. 9 | 10 | 11 | Requirements 12 | ------------ 13 | 14 | - Objective Caml (>= 3.11 is fine, earlier versions are probably fine too) 15 | 16 | - GNU make 17 | 18 | - Findlib (`ocamlfind' command): 19 | http://www.camlcity.org/archive/programming/findlib.html 20 | 21 | - menhir (installation of atd): 22 | http://pauillac.inria.fr/~fpottier/menhir/ 23 | 24 | - easy-format (required for biniou, yojson and atd): 25 | http://martin.jambon.free.fr/easy-format.html 26 | 27 | - cppo (installation of yojson only): 28 | http://martin.jambon.free.fr/cppo.html 29 | 30 | - biniou (>= 1.0.0): 31 | http://martin.jambon.free.fr/biniou.html 32 | 33 | - yojson (>= 1.0.0): 34 | http://martin.jambon.free.fr/yojson.html 35 | 36 | - atd (>= 1.0.0): 37 | http://oss.wink.com/atd/ 38 | 39 | 40 | Manual installation 41 | ------------------- 42 | 43 | make # or `make all' for the bytecode-only version 44 | 45 | make install # or `make BINDIR=/foo/bin install' for installing executables 46 | # in a place other than the guessed default. 47 | 48 | 49 | Manual uninstallation 50 | --------------------- 51 | 52 | make uninstall 53 | 54 | 55 | 56 | Getting started 57 | --------------- 58 | 59 | First take a look at the example in the `example' subdirectory. 60 | 61 | Commands installed by the different packages: 62 | 63 | - atdgen: produces OCaml code from ATD type definitions 64 | - atdcat: pretty-prints ATD type definitions 65 | - bdump: displays biniou data in human-readable form 66 | - ydump: pretty-prints JSON data 67 | 68 | Sources of documentation: 69 | 70 | - command-line interface help: `atdgen -help' 71 | - type definition syntax: atd manual 72 | - options available for each language (ocaml, biniou, json, doc): atdgen manual 73 | - generic biniou tree: biniou documentation, module Bi_io 74 | - generic JSON tree: yojson documentation, module Yojson.Safe 75 | - biniou input buffers: biniou documentation, module Bi_inbuf 76 | - output buffers: biniou documentation, module Bi_outbuf 77 | 78 | 79 | Contact 80 | ------- 81 | Bugs and feedback should be sent to Martin Jambon 82 | or . 83 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 MyLife 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | JBUILDER ?= jbuilder 2 | 3 | all: 4 | $(JBUILDER) build 5 | 6 | tests: 7 | $(JBUILDER) runtest 8 | 9 | check: tests 10 | 11 | clean: 12 | rm -rf _build *.install 13 | 14 | .PHONY: all tests clean check 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repository is retired. Development continues https://github.com/mjambon/atd 2 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | * Support JSON object syntax for variants, e.g.: 2 | type t = A | B of int 3 | Currently supported: "A" 4 | ["B", 123] 5 | <"A"> 6 | <"B":123> 7 | To do: {"A": null} 8 | {"B": 123} 9 | 10 | * Find a good way to support variants represented as records whose type is 11 | given by one of their fields. 12 | 13 | * Plans for atdgen 2: 14 | - create one (sub)command for each target language 15 | (atdgen-ocaml, atdgen-java, atdgen-atd, atdgen-ts) 16 | - imply -std-json, i.e. do not produce code that produces JSON 17 | in the extended syntax for variants (<"A">, <"B":123>) 18 | or tuples (("a", 123, {"x":0})) 19 | - make it possible to produce all outputs in one call to atdgen. 20 | "atdgen foo -m tjv" would read file "foo.atd" and produce 21 | files foo_{t|j|v}.{ml|mli} 22 | - use classic variants instead of polymorphic variants by default 23 | since ocaml >= 4.01 makes them easier to use 24 | 25 | * Support for other languages: 26 | - merge atdj (JSON serializers for Java) into atdgen 27 | - translate ATD into TypeScript type definitions 28 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | 1.10.2 -------------------------------------------------------------------------------- /atdgen-cppo/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2012 Martin Jambon 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /atdgen-cppo/README.md: -------------------------------------------------------------------------------- 1 | `cppo-json` is a preprocessor that replaces embedded type definition 2 | directives with OCaml type definitions and JSON 3 | serialization/deserialization code. 4 | 5 | `atdgen-cppo` is the script that reads type definitions from stdin and 6 | generates OCaml code. It takes options allowing users to pick what 7 | kind of code needs to be generated (type definitions, JSON 8 | serialization, Biniou serialization, validators). 9 | 10 | Example 11 | ------- 12 | 13 | Sample input: 14 | 15 | ``` 16 | $ cat example.ml 17 | #ext json 18 | type mytype = string list 19 | #endext 20 | let data = [ "Hello"; "world" ] 21 | let () = print_endline (J.string_of_mytype data) 22 | ``` 23 | 24 | How to view the OCaml code produced by cppo-json: 25 | 26 | ``` 27 | $ cppo-json < example.ml | less 28 | ``` 29 | 30 | How to compile an OCaml program: 31 | 32 | ``` 33 | $ ocamlfind opt -o example \ 34 | -pp cppo-json \ 35 | -package atdgen -linkpkg \ 36 | example.ml 37 | ``` 38 | 39 | cppo-json ships with atdgen-cppo and is shorthand for the following command: 40 | 41 | ``` 42 | cppo -x "json:atdgen-cppo t j v" 43 | ``` 44 | 45 | where `t` stands for "type definitions", `j` stands for "JSON", and 46 | `v` stands for "validators". 47 | 48 | See also: 49 | ``` 50 | $ cppo-json --help 51 | $ atdgen-cppo --help 52 | $ cppo --help 53 | ``` 54 | 55 | 56 | Documentation 57 | ------------- 58 | 59 | Documentation is provided by the `--help` option of each command. 60 | 61 | Direct dependencies 62 | ------------------- 63 | 64 | * [atdgen](https://github.com/MyLifeLabs/atdgen) 65 | * [cppo](https://github.com/mjambon/cppo) 66 | 67 | Installation 68 | ------------ 69 | 70 | It's just two shell scripts. You can copy them by hand to the 71 | directory of your choice or run: 72 | 73 | ``` 74 | $ make install # installs into $HOME/bin 75 | ``` 76 | 77 | or 78 | 79 | ``` 80 | $ BINDIR=/path/to/bin make install 81 | ``` 82 | -------------------------------------------------------------------------------- /atdgen-cppo/atdgen-cppo: -------------------------------------------------------------------------------- 1 | #! /bin/sh -e 2 | version=1.0.0 3 | 4 | self="$0" 5 | usage () { 6 | echo "\ 7 | Usage: $self [t] [b] [j] [v] 8 | 9 | atdgen-cppo makes it possible to use atdgen to derive code from ATD 10 | type definitions embedded in OCaml source files rather than in 11 | separate .atd files. This is similar to how json-static is used, 12 | except that the preprocessor is not camlp4 but the simpler program cppo. 13 | 14 | Modes: 15 | t produce a module T containing OCaml type definitions translated from ATD 16 | b produce a module B containing OCaml code for biniou serialization 17 | j produce a module J containing OCaml code JSON serialization 18 | v produce a module V containing OCaml code for validation 19 | 20 | Typical usage: 21 | 22 | \$ cat example.ml 23 | #ext json 24 | type mytype = string list 25 | #endext 26 | let data = [ \"Hello\"; \"world\" ] 27 | let () = print_endline (J.string_of_mytype data) 28 | 29 | \$ ocamlfind opt -o example \\ 30 | -pp 'cppo -x \"json:$self t j\"' \\ 31 | -package atdgen -linkpkg example.ml 32 | 33 | \$ ./example 34 | [\"Hello\",\"world\"] 35 | " >&2 36 | } 37 | 38 | case "$1" in 39 | -h|-help|--help) usage; exit 0 ;; 40 | *) ;; 41 | esac 42 | 43 | tmp=$(tempfile -p ml- -s -atdgen-cppo.ml) 44 | cat > $tmp 45 | 46 | fail () { 47 | rm -f $tmp 48 | exit 1 49 | } 50 | 51 | # CPPO_FIRST_LINE is off by one in cppo 0.9.1. 52 | # Should be fixed in cppo rather than here. 53 | gen () { 54 | echo "module $1 = (" 55 | atdgen \ 56 | -pos-fname "$CPPO_FILE" \ 57 | -pos-lnum $(( $CPPO_FIRST_LINE + 1 )) \ 58 | -$2 < $tmp || fail 59 | echo ")" 60 | } 61 | 62 | while [ $# != 0 ]; do 63 | case "$1" in 64 | t) gen T t ;; 65 | b) gen B b ;; 66 | j) gen J j ;; 67 | v) gen V v ;; 68 | --help|-help) usage; exit 0 ;; 69 | *) usage; exit 2 70 | esac 71 | shift 72 | done 73 | 74 | rm -f $tmp 75 | -------------------------------------------------------------------------------- /atdgen-cppo/cppo-json: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | usage () { 4 | echo "\ 5 | Usage: cppo-json [cppo arguments] 6 | 7 | cppo-json processes an OCaml file written with embedded type definitions 8 | directives and replaces them by OCaml type definitions and JSON 9 | serialization/deserialization code. 10 | 11 | Sample input: 12 | 13 | \$ cat example.ml 14 | #ext json 15 | type mytype = string list 16 | #endext 17 | let data = [ \"Hello\"; \"world\" ] 18 | let () = print_endline (J.string_of_mytype data) 19 | 20 | How to view the OCaml code produced by cppo-json: 21 | 22 | \$ cppo-json < example.ml | less 23 | 24 | How to compile an OCaml program: 25 | 26 | \$ ocamlfind opt -o example \\ 27 | -pp cppo-json \\ 28 | -package atdgen -linkpkg \\ 29 | example.ml 30 | 31 | cppo-json ships with atdgen-cppo and is shorthand for the following command: 32 | 33 | cppo -x \"json:atdgen-cppo t j v\" 34 | 35 | where 't' stands for 'type definitions', 'j' stands for 'JSON', and 36 | 'v' stands for \"validators\". 37 | 38 | See also: 39 | atdgen-cppo --help 40 | cppo --help 41 | " >&2 42 | } 43 | 44 | case "$1" in 45 | --help|-help) usage; exit 0 ;; 46 | *) 47 | esac 48 | 49 | cppo -x "json:atdgen-cppo t j v" "$@" 50 | 51 | case $? in 52 | 0) ;; 53 | *) 54 | echo "cppo-json failed" >&2 55 | exit 2 56 | esac 57 | -------------------------------------------------------------------------------- /atdgen-cppo/example.ml: -------------------------------------------------------------------------------- 1 | #ext json 2 | type mytype = string list 3 | #endext 4 | let data = [ "Hello"; "world" ] 5 | let () = print_endline (J.string_of_mytype data) 6 | -------------------------------------------------------------------------------- /atdgen-cppo/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (install 4 | ((section bin) 5 | (files (atdgen-cppo cppo-json)))) -------------------------------------------------------------------------------- /atdgen.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "martin@mjambon.com" 3 | authors: ["Martin Jambon"] 4 | 5 | homepage: "https://github.com/mjambon/atdgen" 6 | bug-reports: "https://github.com/mjambon/atdgen/issues" 7 | dev-repo: "https://github.com/mjambon/atdgen.git" 8 | 9 | build: [ 10 | ["jbuilder" "build" "-p" name "-j" jobs] 11 | ] 12 | 13 | build-test: [ 14 | ["jbuilder" "runtest" "-p" name] 15 | ] 16 | 17 | depends: [ 18 | "jbuilder" {build} 19 | "atd" {>= "1.1.0"} 20 | "biniou" {>= "1.0.6"} 21 | "yojson" {>= "1.2.1" } 22 | ] 23 | -------------------------------------------------------------------------------- /bin/ag_main.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | let append l1 l2 = 5 | List.flatten (List.map (fun s1 -> List.map (fun s2 -> s1 ^ s2) l2) l1) 6 | 7 | let get_file_list base = 8 | append (append [base] ["_t";"_b";"_j";"_v"]) [".mli";".ml"] 9 | 10 | let print_file_list base = 11 | let l = get_file_list base in 12 | print_endline (String.concat " " l) 13 | 14 | let print_deps base = 15 | let l = get_file_list base in 16 | List.iter (fun out -> printf "%s: %s.atd\n" out base) l; 17 | flush stdout 18 | 19 | let set_once varname var x = 20 | match !var with 21 | Some y -> 22 | if x <> y then 23 | failwith (sprintf "\ 24 | Command-line parameter %S is set multiple times 25 | to incompatible values." 26 | varname) 27 | 28 | | None -> 29 | var := Some x 30 | 31 | type mode = 32 | [ `T (* -t (type defs and create_* functions) *) 33 | | `B (* -b (biniou serialization) *) 34 | | `J (* -j (json serialization) *) 35 | | `V (* -v (validators) *) 36 | | `Dep (* -dep (print all file dependencies produced by -t -b -j -v) *) 37 | | `List (* -list (list all files produced by -t -b -j -v) *) 38 | 39 | | `Biniou (* -biniou (deprecated) *) 40 | | `Json (* -json (deprecated) *) 41 | | `Validate (* -validate (deprecated) *) 42 | ] 43 | 44 | type conv = 45 | [ `Ppx of string list 46 | | `Camlp4 of string list ] 47 | 48 | let parse_ocaml_version () = 49 | let re = Str.regexp "^\\([0-9]+\\)\\.\\([0-9]+\\)" in 50 | if Str.string_match re Sys.ocaml_version 0 then 51 | let major = Str.matched_group 1 Sys.ocaml_version in 52 | let minor = Str.matched_group 2 Sys.ocaml_version in 53 | Some (int_of_string major, int_of_string minor) 54 | else 55 | None 56 | 57 | let get_default_name_overlap ocaml_version = 58 | match ocaml_version with 59 | | Some (major, minor) when major < 4 -> false 60 | | Some (4, 0) -> false 61 | | _ -> true 62 | 63 | let main () = 64 | let pos_fname = ref None in 65 | let pos_lnum = ref None in 66 | let files = ref [] in 67 | let opens = ref [] in 68 | let with_typedefs = ref None in 69 | let with_create = ref None in 70 | let with_fundefs = ref None in 71 | let all_rec = ref false in 72 | let out_prefix = ref None in 73 | let mode = ref (None : mode option) in 74 | let std_json = ref false in 75 | let j_preprocess_input = ref None in 76 | let j_defaults = ref false in 77 | let unknown_field_handler = ref None in 78 | let constr_mismatch_handler = ref None in 79 | let type_aliases = ref None in 80 | let ocaml_version = parse_ocaml_version () in 81 | let name_overlap = ref (get_default_name_overlap ocaml_version) in 82 | let set_opens s = 83 | let l = Str.split (Str.regexp " *, *\\| +") s in 84 | opens := List.rev_append l !opens 85 | in 86 | let pp_convs : conv ref = ref (`Ppx []) in 87 | let options = [ 88 | "-type-conv", Arg.String (fun s -> 89 | pp_convs := `Camlp4 (Str.split (Str.regexp ",") s)), 90 | " 91 | GEN1,GEN2,... 92 | Insert 'with GEN1, GEN2, ...' after OCaml type definitions for the 93 | type-conv preprocessor 94 | "; 95 | "-deriving-conv", Arg.String (fun s -> 96 | pp_convs := `Ppx (Str.split (Str.regexp ",") s)), 97 | " 98 | GEN1,GEN2,... 99 | Insert 'with GEN1, GEN2, ...' after OCaml type definitions for the 100 | ppx_deriving preprocessor 101 | "; 102 | "-t", Arg.Unit (fun () -> 103 | set_once "output type" mode `T; 104 | set_once "no function definitions" with_fundefs false), 105 | " 106 | Produce files example_t.mli and example_t.ml 107 | containing OCaml type definitions derived from example.atd."; 108 | 109 | "-b", Arg.Unit (fun () -> set_once "output type" mode `B), 110 | " 111 | Produce files example_b.mli and example_b.ml 112 | containing OCaml serializers and deserializers for the Biniou 113 | data format from the specifications in example.atd."; 114 | 115 | "-j", Arg.Unit (fun () -> set_once "output type" mode `J), 116 | " 117 | Produce files example_j.mli and example_j.ml 118 | containing OCaml serializers and deserializers for the JSON 119 | data format from the specifications in example.atd."; 120 | 121 | "-v", Arg.Unit (fun () -> set_once "output type" mode `V), 122 | " 123 | Produce files example_v.mli and example_v.ml 124 | containing OCaml functions for creating records and 125 | validators from the specifications in example.atd."; 126 | 127 | "-dep", Arg.Unit (fun () -> set_once "output type" mode `Dep), 128 | " 129 | Output Make-compatible dependencies for all possible 130 | products of atdgen -t, -b, -j and -v, and exit."; 131 | 132 | "-list", Arg.Unit (fun () -> set_once "output type" mode `List), 133 | " 134 | Output a space-separated list of all possible products of 135 | atdgen -t, -b, -j and -v, and exit."; 136 | 137 | "-o", Arg.String (fun s -> 138 | let out = 139 | match s with 140 | "-" -> `Stdout 141 | | s -> `Files s 142 | in 143 | set_once "output prefix" out_prefix out), 144 | "[ PREFIX | - ] 145 | Use this prefix for the generated files, e.g. 'foo/bar' for 146 | foo/bar.ml and foo/bar.mli. 147 | `-' designates stdout and produces code of the form 148 | struct ... end : sig ... end"; 149 | 150 | "-biniou", 151 | Arg.Unit (fun () -> 152 | set_once "output type" mode `Biniou), 153 | " 154 | [deprecated in favor of -t and -b] 155 | Produce serializers and deserializers for Biniou 156 | including OCaml type definitions (default)."; 157 | 158 | "-json", 159 | Arg.Unit (fun () -> 160 | set_once "output type" mode `Json), 161 | " 162 | [deprecated in favor of -t and -j] 163 | Produce serializers and deserializers for JSON 164 | including OCaml type definitions."; 165 | 166 | "-j-std", 167 | Arg.Unit (fun () -> 168 | std_json := true), 169 | " 170 | Convert tuples and variants into standard JSON and 171 | refuse to print NaN and infinities (implying -json mode 172 | unless another mode is specified)."; 173 | 174 | "-std-json", 175 | Arg.Unit (fun () -> 176 | std_json := true), 177 | " 178 | [deprecated in favor of -j-std] 179 | Same as -j-std."; 180 | 181 | "-j-pp", 182 | Arg.String (fun s -> set_once "-j-pp" j_preprocess_input s), 183 | " 184 | OCaml function of type (string -> string) applied on the input 185 | of each *_of_string function generated by atdgen (JSON mode). 186 | This is originally intended for UTF-8 validation of the input 187 | which is not performed by atdgen."; 188 | 189 | "-j-defaults", 190 | Arg.Set j_defaults, 191 | " 192 | Output JSON record fields even if their value is known 193 | to be the default."; 194 | 195 | "-j-strict-fields", 196 | Arg.Unit ( 197 | fun () -> 198 | set_once "unknown field handler" unknown_field_handler 199 | "!Ag_util.Json.unknown_field_handler" 200 | ), 201 | " 202 | Call !Ag_util.Json.unknown_field_handler for every unknown JSON field 203 | found in the input instead of simply skipping them. 204 | The initial behavior is to raise an exception."; 205 | 206 | "-j-custom-fields", 207 | Arg.String ( 208 | fun s -> 209 | set_once "unknown field handler" unknown_field_handler s 210 | ), 211 | "FUNCTION 212 | Call the given function of type (string -> unit) 213 | for every unknown JSON field found in the input 214 | instead of simply skipping them. 215 | See also -j-strict-fields."; 216 | 217 | "-j-strict-constrs", 218 | Arg.Unit ( 219 | fun () -> 220 | set_once "constructor mismatch handler" constr_mismatch_handler 221 | "!Ag_util.Json.constr_mismatch_handler" 222 | ), 223 | " 224 | Given a record type of the form 225 | { t: string; v : v }, 226 | this option allows the user to define a runtime conflict handler. 227 | A conflict occurs when trying to serialize an OCaml record 228 | such as { t = \"A\"; v = `B } into JSON. 229 | A correct record might be { t = \"B\"; v = `B } 230 | or { t = \"A\"; v = `A 123 }. 231 | 232 | With this option, !Ag_util.Json.constr_mismatch_handler is called 233 | for every mismatched constructor field value and value 234 | field constructor in the data structures to output instead 235 | of simply serializing them. 236 | The initial behavior is to raise an exception."; 237 | 238 | "-validate", 239 | Arg.Unit (fun () -> 240 | set_once "output type" mode `Validate), 241 | " 242 | [deprecated in favor of -t and -v] 243 | Produce data validators from annotations 244 | where x is a user-written validator to be applied on a specific 245 | node. 246 | This is typically used in conjunction with -extend because 247 | user-written validators depend on the type definitions."; 248 | 249 | "-extend", Arg.String (fun s -> type_aliases := Some s), 250 | "MODULE 251 | Assume that all type definitions are provided by the specified 252 | module unless otherwise annotated. Type aliases are created 253 | for each type, e.g. 254 | type t = Module.t"; 255 | 256 | "-open", Arg.String set_opens, 257 | "MODULE1,MODULE2,... 258 | List of modules to open (comma-separated or space-separated)"; 259 | 260 | "-nfd", Arg.Unit (fun () -> 261 | set_once "no function definitions" with_fundefs false), 262 | " 263 | Do not dump OCaml function definitions"; 264 | 265 | "-ntd", Arg.Unit (fun () -> 266 | set_once "no type definitions" with_typedefs false), 267 | " 268 | Do not dump OCaml type definitions"; 269 | 270 | "-pos-fname", Arg.String (set_once "pos-fname" pos_fname), 271 | "FILENAME 272 | Source file name to use for error messages 273 | (default: input file name)"; 274 | 275 | "-pos-lnum", Arg.Int (set_once "pos-lnum" pos_lnum), 276 | "LINENUM 277 | Source line number of the first line of the input (default: 1)"; 278 | 279 | "-rec", Arg.Set all_rec, 280 | " 281 | Keep OCaml type definitions mutually recursive"; 282 | 283 | "-o-name-overlap", Arg.Set name_overlap, 284 | " 285 | Accept records and classic (non-polymorphic) variants with identical 286 | field or constructor names in the same module. Overlapping names are 287 | supported in OCaml since version 4.01. 288 | 289 | Duplicate name checking will be skipped, and type annotations will 290 | be included in the implementation to disambiguate names. 291 | This is the default if atdgen was compiled for OCaml >= 4.01.0"; 292 | 293 | "-o-no-name-overlap", Arg.Clear name_overlap, 294 | " 295 | Disallow records and classic (non-polymorphic) variants 296 | with identical field or constructor names in the same module. 297 | This is the default if atdgen was compiled for OCaml < 4.01.0"; 298 | 299 | "-version", 300 | Arg.Unit (fun () -> 301 | print_endline Ag_version.version; 302 | exit 0), 303 | " 304 | Print the version identifier of atdgen and exit."; 305 | ] 306 | in 307 | let msg = sprintf "\ 308 | Generate OCaml code offering: 309 | * OCaml type definitions translated from ATD file (-t) 310 | * serializers and deserializers for Biniou (-b) 311 | * serializers and deserializers for JSON (-j) 312 | * record-creating functions supporting default fields (-v) 313 | * user-specified data validators (-v) 314 | 315 | Recommended usage: %s (-t|-b|-j|-v|-dep|-list) example.atd" Sys.argv.(0) in 316 | Arg.parse options (fun file -> files := file :: !files) msg; 317 | 318 | if (!std_json 319 | || !unknown_field_handler <> None 320 | || !constr_mismatch_handler <> None) && !mode = None then 321 | set_once "output mode" mode `Json; 322 | 323 | let mode = 324 | match !mode with 325 | None -> `Biniou 326 | | Some x -> x 327 | in 328 | 329 | let with_create = 330 | match !with_create with 331 | Some x -> x 332 | | None -> 333 | match mode with 334 | `T | `B | `J -> false 335 | | `V -> true 336 | | `Biniou | `Json | `Validate -> true 337 | | `Dep | `List -> true (* don't care *) 338 | in 339 | 340 | let force_defaults = 341 | match mode with 342 | `J | `Json -> !j_defaults 343 | | `T 344 | | `B | `Biniou 345 | | `V | `Validate 346 | | `Dep | `List -> false (* don't care *) 347 | in 348 | 349 | let atd_file = 350 | match !files with 351 | [s] -> Some s 352 | | [] -> None 353 | | _ -> 354 | Arg.usage options msg; 355 | exit 1 356 | in 357 | let base_ocaml_prefix = 358 | match !out_prefix, atd_file with 359 | Some x, _ -> x 360 | | None, Some file -> 361 | `Files ( 362 | if Filename.check_suffix file ".atd" then 363 | Filename.chop_extension file 364 | else 365 | file 366 | ) 367 | | None, None -> `Stdout 368 | in 369 | let base_prefix, ocaml_prefix = 370 | match base_ocaml_prefix with 371 | `Stdout -> None, `Stdout 372 | | `Files base -> 373 | Some base, `Files 374 | (match mode with 375 | `T -> base ^ "_t" 376 | | `B -> base ^ "_b" 377 | | `J -> base ^ "_j" 378 | | `V -> base ^ "_v" 379 | | _ -> base 380 | ) 381 | in 382 | let type_aliases = 383 | match base_prefix with 384 | None -> 385 | (match mode with 386 | `B | `J | `V -> Some "T" 387 | | _ -> None 388 | ) 389 | | Some base -> 390 | match !type_aliases with 391 | Some _ as x -> x 392 | | None -> 393 | (match mode with 394 | `B | `J | `V -> 395 | Some (String.capitalize (Filename.basename base) ^ "_t") 396 | | _ -> None 397 | ) 398 | in 399 | let get_base_prefix () = 400 | match base_prefix with 401 | None -> failwith "Undefined output file names" 402 | | Some s -> s 403 | in 404 | match mode with 405 | `Dep -> print_deps (get_base_prefix ()) 406 | | `List -> print_file_list (get_base_prefix ()) 407 | | `T | `B | `J | `V | `Biniou | `Json | `Validate -> 408 | 409 | let opens = List.rev !opens in 410 | let make_ocaml_files = 411 | match mode with 412 | `T -> 413 | Ag_ob_emit.make_ocaml_files 414 | | `B | `Biniou -> 415 | Ag_ob_emit.make_ocaml_files 416 | | `J | `Json -> 417 | Ag_oj_emit.make_ocaml_files 418 | ~std: !std_json 419 | ~unknown_field_handler: !unknown_field_handler 420 | ~constr_mismatch_handler: !constr_mismatch_handler 421 | ~preprocess_input: !j_preprocess_input 422 | | `V | `Validate -> 423 | Ag_ov_emit.make_ocaml_files 424 | | _ -> assert false 425 | in 426 | let with_default default = function None -> default | Some x -> x in 427 | 428 | make_ocaml_files 429 | ~pp_convs: !pp_convs 430 | ~opens 431 | ~with_typedefs: (with_default true !with_typedefs) 432 | ~with_create 433 | ~with_fundefs: (with_default true !with_fundefs) 434 | ~all_rec: !all_rec 435 | ~pos_fname: !pos_fname 436 | ~pos_lnum: !pos_lnum 437 | ~type_aliases 438 | ~force_defaults 439 | ~ocaml_version 440 | ~name_overlap: !name_overlap 441 | atd_file ocaml_prefix 442 | 443 | let () = 444 | try main () 445 | with 446 | Atd_ast.Atd_error s 447 | | Failure s -> 448 | flush stdout; 449 | eprintf "%s\n%!" s; 450 | exit 1 451 | | e -> raise e 452 | -------------------------------------------------------------------------------- /bin/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((libraries (atdgen)) 5 | (names (ag_main)) 6 | (public_names (atdgen)) 7 | (package atdgen))) -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default 2 | default: 3 | ./example.sh 4 | 5 | .PHONY: clean 6 | rm -f *.cm[iox] *.o *.annot \ 7 | format_v[12].mli format_v[12].ml \ 8 | upgrade_demo upgrade_demo.exe \ 9 | old_sample.dat new_sample.dat \ 10 | old_data.dat new_data.dat 11 | -------------------------------------------------------------------------------- /example/README: -------------------------------------------------------------------------------- 1 | 2 | Example using atdgen 3 | ==================== 4 | 5 | 6 | This simple but standalone example illustrates the use of atdgen to 7 | manage a backward-compatible change of data format. 8 | 9 | The old data format is defined in `format_v1.atd'. The newer data 10 | format is defined in `format_v2.atd'. It is a record type from which 11 | one field was removed and another field was added. 12 | 13 | The program `upgrade_demo' demonstrates the use of atdgen in general 14 | and how to make a data format evolve without losing compatibility 15 | with legacy data files or services. 16 | 17 | 1. Atdgen must be installed properly 18 | 2. Run `make' 19 | 3. Inspect the files starting with example.sh 20 | -------------------------------------------------------------------------------- /example/example.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | echo "Running script $0, look inside for comments." 4 | 5 | # Exit on error 6 | set -e 7 | 8 | # Produce format_v1.mli and format_v1.ml from type definition 9 | atdgen format_v1.atd 10 | 11 | # Produce format_v2.mli and format_v2.ml from type definition 12 | atdgen format_v2.atd 13 | 14 | # Compile and link all OCaml code, producing upgrade_demo 15 | ocamlfind ocamlopt -g -dtypes -package atdgen -linkpkg \ 16 | format_v1.mli format_v1.ml \ 17 | format_v2.mli format_v2.ml \ 18 | upgrade_demo.ml -o upgrade_demo 19 | 20 | # Save biniou sample in the old format 21 | ./upgrade_demo old > old_sample.dat 22 | 23 | # Save the same data after conversion to the new format 24 | ./upgrade_demo new > new_sample.dat 25 | 26 | # Use our sample data in the old format for the next test 27 | cp old_sample.dat old_data.dat 28 | 29 | # Read data in the old format with code assuming the new format 30 | ./upgrade_demo up < old_data.dat > new_data.dat 31 | 32 | # Dump a text representation of old and new data. 33 | # The -w option specifies a list of candidate field names required for 34 | # converting hashed field names into the original names. 35 | echo "Data in format v1:" 36 | bdump old_data.dat -w a,b,c,d 37 | echo "Converted to format v2:" 38 | bdump new_data.dat -w a,c,d,e 39 | echo "Same, displayed using incomplete name dictionary:" 40 | bdump new_data.dat -w a,b 41 | -------------------------------------------------------------------------------- /example/format_v1.atd: -------------------------------------------------------------------------------- 1 | (* Older version of an imagined data format *) 2 | 3 | type t = { 4 | a : int option; 5 | b : bool; 6 | ?c : int option; 7 | ~d : float; 8 | } 9 | -------------------------------------------------------------------------------- /example/format_v2.atd: -------------------------------------------------------------------------------- 1 | (* Newer version of an imagined data format. Compare to `format_v1.atd'. *) 2 | 3 | type t = { 4 | a : int option; 5 | (* removed field b, making newer data unreadable with older software since 6 | b was not optional. *) 7 | ?c : int option; 8 | ~d : float; 9 | ~e : string list; (* added optional field e, allowing newer software 10 | to read older data. *) 11 | } 12 | -------------------------------------------------------------------------------- /example/upgrade_demo.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let old_data = { 4 | Format_v1.a = Some 1; 5 | b = true; 6 | c = Some 3; 7 | d = 4.0; 8 | } 9 | 10 | let print_old_data () = 11 | let ob = Bi_outbuf.create_channel_writer stdout in 12 | Format_v1.write_t ob old_data; 13 | Bi_outbuf.flush_channel_writer ob; 14 | flush stdout 15 | 16 | let convert x = 17 | Format_v2.t_of_string (Format_v1.string_of_t ~len:100 x) 18 | 19 | let print_new_data () = 20 | let new_data = convert old_data in 21 | let ob = Bi_outbuf.create_channel_writer stdout in 22 | Format_v2.write_t ob new_data; 23 | Bi_outbuf.flush_channel_writer ob; 24 | flush stdout 25 | 26 | let upgrade () = 27 | let ib = Bi_inbuf.from_channel stdin in 28 | let x = Format_v2.read_t ib in 29 | let ob = Bi_outbuf.create_channel_writer stdout in 30 | Format_v2.write_t ob x; 31 | Bi_outbuf.flush_channel_writer ob; 32 | flush stdout 33 | 34 | 35 | let usage () = 36 | eprintf "\ 37 | Usage: %s [old|new|up] 38 | 39 | old print sample data in the old format 40 | new print sample data in the new format 41 | up read data in the new format from stdin and print data in the new format 42 | %!" 43 | Sys.argv.(0); 44 | exit 1 45 | 46 | let main () = 47 | match Sys.argv with 48 | [| _; action |] -> 49 | (match action with 50 | "old" -> print_old_data () 51 | | "new" -> print_new_data () 52 | | "up" -> upgrade () 53 | | _ -> usage () 54 | ) 55 | | _ -> usage () 56 | 57 | let () = main () 58 | -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | META 2 | VERSION 3 | ag_version.ml 4 | test.ml 5 | test.mli 6 | test2.ml 7 | test2.mli 8 | test2j.ml 9 | test2j.mli 10 | test3b.ml 11 | test3b.mli 12 | test3j.ml 13 | test3j.mli 14 | test4.ml 15 | test4.mli 16 | test4j.ml 17 | test4j.mli 18 | test5_b.ml 19 | test5_b.mli 20 | test5_j.ml 21 | test5_j.mli 22 | test5_t.ml 23 | test5_t.mli 24 | testj.ml 25 | testj.mli 26 | testjstd.ml 27 | testjstd.mli 28 | testv.ml 29 | testv.mli 30 | test-2.bin 31 | test-2.json 32 | test-json-files.json 33 | test-json-streams.json 34 | test-std.json 35 | test.bin 36 | test.json 37 | test_atdgen 38 | testdoc 39 | ag_doc_lexer.ml 40 | atdgen 41 | dep 42 | -------------------------------------------------------------------------------- /src/ag_biniou.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Mapping from ATD to biniou 3 | *) 4 | 5 | type biniou_int = 6 | [ `Svint | `Uvint | `Int8 | `Int16 | `Int32 | `Int64 ] 7 | 8 | type biniou_float = [ `Float32 | `Float64 ] 9 | 10 | type biniou_list = [ `Array | `Table ] 11 | 12 | type biniou_field = { biniou_unwrapped : bool } 13 | 14 | type biniou_repr = 15 | [ 16 | | `Unit 17 | | `Bool 18 | | `Int of biniou_int 19 | | `Float of biniou_float 20 | 21 | | `String 22 | | `Sum 23 | | `Record 24 | | `Tuple 25 | | `List of biniou_list 26 | | `Option 27 | | `Nullable 28 | | `Wrap 29 | | `External 30 | 31 | | `Cell 32 | | `Field of biniou_field 33 | | `Variant 34 | | `Def 35 | ] 36 | 37 | let biniou_int_of_string s : biniou_int option = 38 | match s with 39 | "svint" -> Some `Svint 40 | | "uvint" -> Some `Uvint 41 | | "int8" -> Some `Int8 42 | | "int16" -> Some `Int16 43 | | "int32" -> Some `Int32 44 | | "int64" -> Some `Int64 45 | | _ -> None 46 | 47 | let biniou_float_of_string s : biniou_float option = 48 | match s with 49 | "float32" -> Some `Float32 50 | | "float64" -> Some `Float64 51 | | _ -> None 52 | 53 | let biniou_list_of_string s : biniou_list option = 54 | match s with 55 | "array" -> Some `Array 56 | | "table" -> Some `Table 57 | | _ -> None 58 | 59 | let get_biniou_int an = 60 | Atd_annot.get_field biniou_int_of_string `Svint ["biniou"] "repr" an 61 | 62 | let get_biniou_float an = 63 | Atd_annot.get_field biniou_float_of_string `Float64 ["biniou"] "repr" an 64 | 65 | let get_biniou_list an = 66 | Atd_annot.get_field biniou_list_of_string `Array ["biniou"] "repr" an 67 | -------------------------------------------------------------------------------- /src/ag_doc.ml: -------------------------------------------------------------------------------- 1 | 2 | type inline = 3 | [ `Text of string 4 | | `Code of string ] 5 | type block = [ `Paragraph of inline list | `Pre of string ] 6 | type doc = [ `Text of block list ] 7 | 8 | let parse_text loc s = 9 | try Some (Some (`Text (Ag_doc_lexer.parse_string s : block list))) 10 | with e -> 11 | failwith (Printf.sprintf "%s:\nInvalid format for doc.text %S:\n%s" 12 | (Atd_ast.string_of_loc loc) s (Printexc.to_string e)) 13 | 14 | let get_doc loc an : doc option = 15 | Atd_annot.get_field (parse_text loc) None ["doc"] "text" an 16 | -------------------------------------------------------------------------------- /src/ag_doc.mli: -------------------------------------------------------------------------------- 1 | 2 | (** 3 | Support for annotations: 4 | 5 | type foo = [ Bar of int ] 6 | 7 | This allows code generators to inject the documentation into the 8 | generated code. 9 | 10 | nodes that appear in the following positions should be taken into 11 | account by code generators that care about documentation: 12 | 13 | - after the type name on the left-hand side of a type definition 14 | - after the type expression on the right-hand side of a type definition 15 | (but not after any type expression) 16 | - after record field names 17 | - after variant names 18 | 19 | Formats: 20 | 21 | Currently only one format called "text" is supported: 22 | - Blank lines separate paragraphs. 23 | - [\{\{ \}\}] can be used to enclose inline verbatim text. 24 | - [\{\{\{ \}\}\}] can be used to enclose verbatim text where whitespace 25 | is preserved. 26 | - The backslash character is used to escape special character sequences. 27 | In regular paragraph mode the special sequences are [\ ], [\{\{] 28 | and [\{\{\{]. 29 | In inline verbatim text, special sequences are [\ ] and [\}\}]. 30 | In verbatim text, special sequences are [\ ] and [\}\}\}]. 31 | 32 | Character encoding: UTF-8 is strongly recommended, if not plain ASCII. 33 | *) 34 | 35 | type inline = 36 | [ `Text of string 37 | | `Code of string ] 38 | (** [`Text] is regular text. [`Code] is text that was enclosed 39 | within [\{\{ \}\}] and should be rendered using the 40 | same fixed-width font used in all verbatim text. *) 41 | 42 | type block = [ `Paragraph of inline list | `Pre of string ] 43 | (** [`Paragraph] is a regular paragraph. 44 | [`Pre] is preformatted text that was enclosed 45 | within [\{\{\{ \}\}\}] and should be rendered using a fixed-width 46 | font preserving all space and newline characters. *) 47 | 48 | type doc = [ `Text of block list ] 49 | (** A document is a list of paragraph-like blocks. *) 50 | 51 | val get_doc : Atd_ast.loc -> Atd_ast.annot -> doc option 52 | (** Get and parse doc data from annotations. *) 53 | -------------------------------------------------------------------------------- /src/ag_doc_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | let close_paragraph a1 a2 a3 = 3 | let a2 = 4 | match String.concat "" (List.rev a3) with 5 | "" -> a2 6 | | s -> `Text s :: a2 7 | in 8 | match List.rev a2 with 9 | [] -> a1 10 | | l -> `Paragraph l :: a1 11 | } 12 | 13 | let space = [' ' '\t' '\r' '\n'] 14 | let space' = space#['\n'] 15 | 16 | let par_special = ['\\' '{' '}'] 17 | let par_not_special = [^ '\\' '{' '}' ' ' '\t' '\r' '\n'] 18 | let verb_not_special = [^ '\\' ' ' '\t' '\r' '\n' '}'] 19 | 20 | 21 | (* 22 | Paragraph mode 23 | *) 24 | rule paragraph a1 a2 a3 = parse 25 | '\\' ('\\' | "{{" | "{{{" as s) 26 | { paragraph a1 a2 (s :: a3) lexbuf } 27 | | "{{" 28 | { let code = inline_verbatim [] lexbuf in 29 | let a2 = 30 | match String.concat "" (List.rev a3) with 31 | "" -> a2 32 | | s -> `Text s :: a2 33 | in 34 | let a2 = `Code code :: a2 in 35 | paragraph a1 a2 [] lexbuf 36 | } 37 | | space* "{{{" (("\r"?) "\n")? 38 | { let pre = verbatim [] lexbuf in 39 | let a1 = close_paragraph a1 a2 a3 in 40 | let a1 = `Pre pre :: a1 in 41 | paragraph a1 [] [] lexbuf 42 | } 43 | | par_not_special+ as s 44 | { paragraph a1 a2 (s :: a3) lexbuf } 45 | | space'* "\n"? space'* 46 | { paragraph a1 a2 (" " :: a3) lexbuf } 47 | | space'* "\n" (space'* "\n")+ space'* 48 | { let a1 = close_paragraph a1 a2 a3 in 49 | paragraph a1 [] [] lexbuf 50 | } 51 | | space* eof { let a1 = close_paragraph a1 a2 a3 in 52 | List.rev a1 } 53 | 54 | | _ as c { paragraph a1 a2 (String.make 1 c :: a3) lexbuf } 55 | 56 | 57 | 58 | (* 59 | Inline verbatim mode: 60 | Only "}}" need to be escaped. 61 | Backslashes can be escaped but single backslashes are tolerated. 62 | *) 63 | and inline_verbatim accu = parse 64 | "\\\\" { inline_verbatim ("\\" :: accu) lexbuf } 65 | | "\\}}" { inline_verbatim ("}}" :: accu) lexbuf } 66 | | space+ { inline_verbatim (" " :: accu) lexbuf } 67 | | verb_not_special+ as s 68 | { inline_verbatim (s :: accu) lexbuf } 69 | | _ as c { inline_verbatim (String.make 1 c :: accu) lexbuf } 70 | 71 | | space* "}}" { String.concat "" (List.rev accu) } 72 | 73 | | eof { failwith "Missing `}}'" } 74 | 75 | 76 | (* 77 | Verbatim paragraph mode: 78 | Only "}}}" need to be escaped. 79 | Backslashes can be escaped but single backslashes are tolerated. 80 | *) 81 | and verbatim accu = parse 82 | "\\\\" { verbatim ("\\" :: accu) lexbuf } 83 | | "\\}}}" { verbatim ("}}}" :: accu) lexbuf } 84 | | '\t' { verbatim (" " :: accu) lexbuf } 85 | | "\r\n" { verbatim ("\n" :: accu) lexbuf } 86 | | verb_not_special+ as s 87 | { verbatim (s :: accu) lexbuf } 88 | | _ as c { verbatim (String.make 1 c :: accu) lexbuf } 89 | 90 | | ('\r'? '\n')? "}}}" { String.concat "" (List.rev accu) } 91 | 92 | | eof { failwith "Missing `}}}'" } 93 | 94 | { 95 | let parse_string s = 96 | let lexbuf = Lexing.from_string s in 97 | paragraph [] [] [] lexbuf 98 | } 99 | -------------------------------------------------------------------------------- /src/ag_error.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | let error loc msg = 5 | failwith (sprintf "%s:\n%s" (Atd_ast.string_of_loc loc) msg) 6 | 7 | let error2 loc1 msg1 loc2 msg2 = 8 | failwith (sprintf "%s:\n%s\n%s:\n%s" 9 | (Atd_ast.string_of_loc loc1) msg1 10 | (Atd_ast.string_of_loc loc2) msg2) 11 | 12 | let error3 loc1 msg1 loc2 msg2 loc3 msg3 = 13 | failwith (sprintf "%s:\n%s\n%s:\n%s\n%s:\n%s" 14 | (Atd_ast.string_of_loc loc1) msg1 15 | (Atd_ast.string_of_loc loc2) msg2 16 | (Atd_ast.string_of_loc loc3) msg3) 17 | -------------------------------------------------------------------------------- /src/ag_indent.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | Atd_indent extended with annnotations allowing some postprocessing. 4 | *) 5 | 6 | type t = 7 | [ 8 | | `Line of string (* single line (not indented) *) 9 | | `Block of t list (* indented sequence *) 10 | | `Inline of t list (* in-line sequence (not indented) *) 11 | | `Annot of (string * t) (* arbitrary annotation *) 12 | ] 13 | 14 | let rec strip : t -> Atd_indent.t = function 15 | `Line _ as x -> x 16 | | `Block l -> `Block (List.map strip l) 17 | | `Inline l -> `Inline (List.map strip l) 18 | | `Annot (_, x) -> strip x 19 | -------------------------------------------------------------------------------- /src/ag_json.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Mapping from ATD to JSON 3 | *) 4 | 5 | type json_float = [ `Float of int option (* max decimal places *) 6 | | `Int ] 7 | 8 | type json_list = [ `Array | `Object ] 9 | 10 | type json_variant = { json_cons : string option } 11 | 12 | type json_field = { 13 | json_fname : string; (* *) 14 | json_tag_field : string option; (* *) 15 | json_unwrapped : bool 16 | } 17 | 18 | type json_repr = 19 | [ 20 | | `Unit 21 | | `Bool 22 | | `Int 23 | | `Float of json_float 24 | 25 | | `String 26 | | `Sum 27 | | `Record 28 | | `Tuple 29 | | `List of json_list 30 | | `Option 31 | | `Nullable 32 | | `Wrap (* should we add support for Base64 encoding of binary data? *) 33 | | `External 34 | 35 | | `Cell 36 | | `Field of json_field 37 | | `Variant of json_variant 38 | | `Def 39 | ] 40 | 41 | let json_float_of_string s : [ `Float | `Int ] option = 42 | match s with 43 | "float" -> Some `Float 44 | | "int" -> Some `Int 45 | | _ -> None 46 | 47 | let json_precision_of_string s = 48 | try Some (Some (int_of_string s)) 49 | with _ -> None 50 | 51 | let get_json_precision an = 52 | Atd_annot.get_field 53 | json_precision_of_string None ["json"] "precision" an 54 | 55 | let get_json_float an : json_float = 56 | match 57 | Atd_annot.get_field json_float_of_string `Float ["json"] "repr" an 58 | with 59 | `Float -> `Float (get_json_precision an) 60 | | `Int -> `Int 61 | 62 | let json_list_of_string s : json_list option = 63 | match s with 64 | "array" -> Some `Array 65 | | "object" -> Some `Object 66 | | _ -> None 67 | 68 | let get_json_list an = 69 | Atd_annot.get_field json_list_of_string `Array ["json"] "repr" an 70 | 71 | let get_json_cons default an = 72 | Atd_annot.get_field (fun s -> Some s) default ["json"] "name" an 73 | 74 | let get_json_fname default an = 75 | Atd_annot.get_field (fun s -> Some s) default ["json"] "name" an 76 | 77 | let get_json_tag_field an = 78 | Atd_annot.get_field (fun s -> Some (Some s)) None ["json"] "tag_field" an 79 | 80 | let get_json_untyped an = 81 | Atd_annot.get_flag ["json"] "untyped" an 82 | -------------------------------------------------------------------------------- /src/ag_json.mli: -------------------------------------------------------------------------------- 1 | 2 | type json_float = [ `Float of int option (* max decimal places *) 3 | | `Int ] 4 | 5 | type json_list = [ `Array | `Object ] 6 | 7 | type json_variant = { json_cons : string option } 8 | 9 | type json_field = { 10 | json_fname : string; (* *) 11 | json_tag_field : string option; (* *) 12 | json_unwrapped : bool 13 | } 14 | type json_repr = 15 | [ `Bool 16 | | `Cell 17 | | `Def 18 | | `External 19 | | `Field of json_field 20 | | `Float of json_float 21 | | `Int 22 | | `List of json_list 23 | | `Nullable 24 | | `Option 25 | | `Record 26 | | `String 27 | | `Sum 28 | | `Tuple 29 | | `Unit 30 | | `Variant of json_variant 31 | | `Wrap ] 32 | 33 | 34 | val get_json_list : Atd_annot.t -> json_list 35 | 36 | val get_json_float : Atd_annot.t -> json_float 37 | 38 | val get_json_cons : string -> Atd_annot.t -> string 39 | 40 | val get_json_fname : string -> Atd_annot.t -> string 41 | 42 | val get_json_tag_field : Atd_annot.t -> string option 43 | 44 | val get_json_untyped : Atd_annot.t -> bool 45 | -------------------------------------------------------------------------------- /src/ag_mapping.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | open Ag_error 4 | 5 | type loc = Atd_ast.loc 6 | 7 | let annot_error loc = 8 | Ag_error.error loc "Invalid annotation" 9 | 10 | type loc_id = string 11 | 12 | (* 13 | Generic mapping, based on the core ATD types 14 | *) 15 | type ('a, 'b) mapping = 16 | [ `Unit of (loc * 'a * 'b) 17 | | `Bool of (loc * 'a * 'b) 18 | | `Int of (loc * 'a * 'b) 19 | | `Float of (loc * 'a * 'b) 20 | | `String of (loc * 'a * 'b) 21 | | `Sum of (loc * ('a, 'b) variant_mapping array * 'a * 'b) 22 | | `Record of (loc * ('a, 'b) field_mapping array * 'a * 'b) 23 | | `Tuple of (loc * ('a, 'b) cell_mapping array * 'a * 'b) 24 | | `List of (loc * ('a, 'b) mapping * 'a * 'b) 25 | | `Option of (loc * ('a, 'b) mapping * 'a * 'b) 26 | | `Nullable of (loc * ('a, 'b) mapping * 'a * 'b) 27 | | `Wrap of (loc * ('a, 'b) mapping * 'a * 'b) 28 | | `Name of (loc * string * ('a, 'b) mapping list * 'a option * 'b option) 29 | | `External of (loc * string * ('a, 'b) mapping list * 'a * 'b) 30 | | `Tvar of (loc * string) ] 31 | 32 | and ('a, 'b) cell_mapping = { 33 | cel_loc : loc; 34 | cel_value : ('a, 'b) mapping; 35 | cel_arepr : 'a; 36 | cel_brepr : 'b 37 | } 38 | 39 | and ('a, 'b) field_mapping = { 40 | f_loc : loc; 41 | f_name : string; 42 | f_kind : Atd_ast.field_kind; 43 | f_value : ('a, 'b) mapping; 44 | f_arepr : 'a; 45 | f_brepr : 'b 46 | } 47 | 48 | and ('a, 'b) variant_mapping = { 49 | var_loc : loc; 50 | var_cons : string; 51 | var_arg : ('a, 'b) mapping option; 52 | var_arepr : 'a; 53 | var_brepr : 'b 54 | } 55 | 56 | type ('a, 'b) def = { 57 | def_loc : loc; 58 | def_name : string; 59 | def_param : string list; 60 | def_value : ('a, 'b) mapping option; 61 | def_arepr : 'a; 62 | def_brepr : 'b; 63 | } 64 | 65 | 66 | let as_abstract = function 67 | `Name (_, (loc, "abstract", l), a) -> 68 | if l <> [] then 69 | error loc "\"abstract\" takes no type parameters"; 70 | Some (loc, a) 71 | | _ -> 72 | None 73 | 74 | let is_abstract x = as_abstract x <> None 75 | 76 | 77 | let loc_of_mapping x = 78 | match (x : (_, _) mapping) with 79 | `Unit (loc, _, _) 80 | | `Bool (loc, _, _) 81 | | `Int (loc, _, _) 82 | | `Float (loc, _, _) 83 | | `String (loc, _, _) 84 | | `Sum (loc, _, _, _) 85 | | `Record (loc, _, _, _) 86 | | `Tuple (loc, _, _, _) 87 | | `List (loc, _, _, _) 88 | | `Option (loc, _, _, _) 89 | | `Nullable (loc, _, _, _) 90 | | `Wrap (loc, _, _, _) 91 | | `Name (loc, _, _, _, _) 92 | | `External (loc, _, _, _, _) 93 | | `Tvar (loc, _) -> loc 94 | 95 | 96 | module Env = Map.Make (String) 97 | 98 | let rec subst env (x : (_, _) mapping) = 99 | match x with 100 | `Unit (loc, _, _) 101 | | `Bool (loc, _, _) 102 | | `Int (loc, _, _) 103 | | `Float (loc, _, _) 104 | | `String (loc, _, _) -> x 105 | | `Sum (loc, ar, a, b) -> 106 | `Sum (loc, Array.map (subst_variant env) ar, a, b) 107 | | `Record (loc, ar, a, b) -> 108 | `Record (loc, Array.map (subst_field env) ar, a, b) 109 | | `Tuple (loc, ar, a, b) -> 110 | `Tuple (loc, Array.map (subst_cell env) ar, a, b) 111 | | `List (loc, x, a, b) -> 112 | `List (loc, subst env x, a, b) 113 | | `Option (loc, x, a, b) -> 114 | `Option (loc, subst env x, a, b) 115 | | `Nullable (loc, x, a, b) -> 116 | `Nullable (loc, subst env x, a, b) 117 | | `Wrap (loc, x, a, b) -> 118 | `Wrap (loc, subst env x, a, b) 119 | | `Name (loc, name, args, a, b) -> 120 | `Name (loc, name, List.map (subst env) args, a, b) 121 | | `External (loc, name, args, a, b) -> 122 | `External (loc, name, List.map (subst env) args, a, b) 123 | | `Tvar (loc, s) -> 124 | try Env.find s env 125 | with Not_found -> 126 | invalid_arg (sprintf "Ag_mapping.subst_var: '%s" s) 127 | 128 | and subst_variant env x = 129 | match x.var_arg with 130 | None -> x 131 | | Some v -> { x with var_arg = Some (subst env v) } 132 | 133 | and subst_field env x = 134 | { x with f_value = subst env x.f_value } 135 | 136 | and subst_cell env x = 137 | { x with cel_value = subst env x.cel_value } 138 | 139 | (* 140 | Substitute type variables param in x by args 141 | *) 142 | let apply param x args = 143 | if List.length param <> List.length args then 144 | invalid_arg "Ag_mapping.apply"; 145 | let env = 146 | List.fold_left2 147 | (fun env var value -> Env.add var value env) 148 | Env.empty param args 149 | in 150 | subst env x 151 | 152 | 153 | let rec find_name loc env visited name = 154 | if List.mem name visited then 155 | error loc "Cyclic type definition" 156 | else 157 | let param, x = Env.find name env in 158 | (param, deref_expr env (name :: visited) x) 159 | 160 | and deref_expr env visited x = 161 | match x with 162 | `Name (loc, name, args, _, _) -> 163 | (try 164 | let param, x = find_name loc env visited name in 165 | apply param x args 166 | with Not_found -> x) 167 | | _ -> x 168 | 169 | let flatten l = List.flatten (List.map snd l) 170 | 171 | let make_deref 172 | (l : (bool * ('a, 'b) def list) list) : 173 | (('a, 'b) mapping -> ('a, 'b) mapping) = 174 | 175 | let defs = 176 | List.fold_left 177 | (fun env d -> 178 | match d.def_value with 179 | None -> env 180 | | Some v -> Env.add d.def_name (d.def_param, v) env) 181 | Env.empty (flatten l) in 182 | 183 | fun x -> deref_expr defs [] x 184 | 185 | (* 186 | Resolve names and unwrap `wrap` constructs 187 | (discarding annotations along the way) 188 | *) 189 | let rec unwrap (deref: ('a, 'b) mapping -> ('a, 'b) mapping) x = 190 | match deref x with 191 | | `Wrap (loc, x, a, b) -> unwrap deref x 192 | | x -> x 193 | 194 | (* This is for debugging *) 195 | let constructor : ('a, 'b) mapping -> string = function 196 | | `Unit _ -> "Unit" 197 | | `Bool _ -> "Bool" 198 | | `Int _ -> "Int" 199 | | `Float _ -> "Float" 200 | | `String _ -> "String" 201 | | `Sum _ -> "Sum" 202 | | `Record _ -> "Record" 203 | | `Tuple _ -> "Tuple" 204 | | `List _ -> "List" 205 | | `Option _ -> "Option" 206 | | `Nullable _ -> "Nullable" 207 | | `Wrap _ -> "Wrap" 208 | | `Name (loc, name, _, _, _) -> "Name " ^ name 209 | | `External _ -> "External" 210 | | `Tvar _ -> "Tvar" 211 | -------------------------------------------------------------------------------- /src/ag_ob_mapping.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Atd_ast 3 | open Ag_error 4 | open Ag_mapping 5 | 6 | type o = Ag_ocaml.atd_ocaml_repr 7 | type b = Ag_biniou.biniou_repr 8 | 9 | type ob_mapping = 10 | (Ag_ocaml.atd_ocaml_repr, Ag_biniou.biniou_repr) Ag_mapping.mapping 11 | 12 | type ob_def = 13 | (Ag_ocaml.atd_ocaml_repr, Ag_biniou.biniou_repr) Ag_mapping.def 14 | 15 | 16 | (* 17 | Translation of the types into the ocaml/biniou mapping. 18 | *) 19 | 20 | let rec mapping_of_expr (x : type_expr) : ob_mapping = 21 | match x with 22 | `Sum (loc, l, an) -> 23 | let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in 24 | let biniou_t = `Sum in 25 | `Sum (loc, Array.of_list (List.map mapping_of_variant l), 26 | ocaml_t, biniou_t) 27 | 28 | | `Record (loc, l, an) -> 29 | let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in 30 | let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in 31 | let biniou_t = `Record in 32 | `Record (loc, 33 | Array.of_list 34 | (List.map (mapping_of_field ocaml_field_prefix) l), 35 | ocaml_t, biniou_t) 36 | 37 | | `Tuple (loc, l, an) -> 38 | let ocaml_t = `Tuple in 39 | let biniou_t = `Tuple in 40 | `Tuple (loc, Array.of_list (List.map mapping_of_cell l), 41 | ocaml_t, biniou_t) 42 | 43 | | `List (loc, x, an) -> 44 | let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in 45 | let biniou_t = `List (Ag_biniou.get_biniou_list an) in 46 | `List (loc, mapping_of_expr x, ocaml_t, biniou_t) 47 | 48 | | `Option (loc, x, an) -> 49 | let ocaml_t = `Option in 50 | let biniou_t = `Option in 51 | `Option (loc, mapping_of_expr x, ocaml_t, biniou_t) 52 | 53 | | `Nullable (loc, x, an) -> 54 | let ocaml_t = `Nullable in 55 | let biniou_t = `Nullable in 56 | `Nullable (loc, mapping_of_expr x, ocaml_t, biniou_t) 57 | 58 | | `Shared (loc, x, a) -> 59 | failwith "Sharing is no longer supported" 60 | 61 | | `Wrap (loc, x, a) -> 62 | let ocaml_t = `Wrap (Ag_ocaml.get_ocaml_wrap loc a) in 63 | let json_t = `Wrap in 64 | `Wrap (loc, mapping_of_expr x, ocaml_t, json_t) 65 | 66 | | `Name (loc, (loc2, s, l), an) -> 67 | (match s with 68 | "unit" -> 69 | `Unit (loc, `Unit, `Unit) 70 | | "bool" -> 71 | `Bool (loc, `Bool, `Bool) 72 | | "int" -> 73 | let o = Ag_ocaml.get_ocaml_int an in 74 | let b = Ag_biniou.get_biniou_int an in 75 | `Int (loc, `Int o, `Int b) 76 | | "float" -> 77 | let b = Ag_biniou.get_biniou_float an in 78 | `Float (loc, `Float, `Float b) 79 | | "string" -> 80 | `String (loc, `String, `String) 81 | | s -> 82 | `Name (loc, s, List.map mapping_of_expr l, None, None) 83 | ) 84 | | `Tvar (loc, s) -> 85 | `Tvar (loc, s) 86 | 87 | and mapping_of_cell (loc, x, an) = 88 | let default = Ag_ocaml.get_ocaml_default an in 89 | let doc = Ag_doc.get_doc loc an in 90 | let ocaml_t = 91 | `Cell { 92 | Ag_ocaml.ocaml_default = default; 93 | ocaml_fname = ""; 94 | ocaml_mutable = false; 95 | ocaml_fdoc = doc; 96 | } 97 | in 98 | let biniou_t = `Cell in 99 | { 100 | cel_loc = loc; 101 | cel_value = mapping_of_expr x; 102 | cel_arepr = ocaml_t; 103 | cel_brepr = biniou_t 104 | } 105 | 106 | 107 | and mapping_of_variant = function 108 | `Variant (loc, (s, an), o) -> 109 | let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in 110 | let doc = Ag_doc.get_doc loc an in 111 | let ocaml_t = 112 | `Variant { 113 | Ag_ocaml.ocaml_cons = ocaml_cons; 114 | ocaml_vdoc = doc; 115 | } 116 | in 117 | let biniou_t = `Variant in 118 | let arg = 119 | match o with 120 | None -> None 121 | | Some x -> Some (mapping_of_expr x) in 122 | { 123 | var_loc = loc; 124 | var_cons = s; 125 | var_arg = arg; 126 | var_arepr = ocaml_t; 127 | var_brepr = biniou_t 128 | } 129 | 130 | | `Inherit _ -> assert false 131 | 132 | and mapping_of_field ocaml_field_prefix = function 133 | `Field (loc, (s, fk, an), x) -> 134 | let fvalue = mapping_of_expr x in 135 | let ocaml_default, biniou_unwrapped = 136 | match fk, Ag_ocaml.get_ocaml_default an with 137 | `Required, None -> None, false 138 | | `Optional, None -> Some "None", true 139 | | (`Required | `Optional), Some _ -> 140 | error loc "Superfluous default OCaml value" 141 | | `With_default, Some s -> Some s, false 142 | | `With_default, None -> 143 | (* will try to determine implicit default value later *) 144 | None, false 145 | in 146 | let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in 147 | let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in 148 | let doc = Ag_doc.get_doc loc an in 149 | { f_loc = loc; 150 | f_name = s; 151 | f_kind = fk; 152 | f_value = fvalue; 153 | 154 | f_arepr = `Field { 155 | Ag_ocaml.ocaml_default = ocaml_default; 156 | ocaml_fname = ocaml_fname; 157 | ocaml_mutable = ocaml_mutable; 158 | ocaml_fdoc = doc; 159 | }; 160 | 161 | f_brepr = `Field { Ag_biniou.biniou_unwrapped = biniou_unwrapped }; 162 | } 163 | 164 | | `Inherit _ -> assert false 165 | 166 | 167 | let def_of_atd (loc, (name, param, an), x) = 168 | let ocaml_predef = Ag_ocaml.get_ocaml_predef `Biniou an in 169 | let doc = Ag_doc.get_doc loc an in 170 | let o = 171 | match as_abstract x with 172 | Some (loc2, an2) -> 173 | (match Ag_ocaml.get_ocaml_module_and_t `Biniou name an with 174 | None -> None 175 | | Some (types_module, main_module, ext_name) -> 176 | let args = List.map (fun s -> `Tvar (loc, s)) param in 177 | Some (`External 178 | (loc, name, args, 179 | `External (types_module, main_module, ext_name), 180 | `External) 181 | ) 182 | ) 183 | | None -> Some (mapping_of_expr x) 184 | in 185 | { 186 | def_loc = loc; 187 | def_name = name; 188 | def_param = param; 189 | def_value = o; 190 | def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; 191 | ocaml_ddoc = doc; }; 192 | def_brepr = `Def; 193 | } 194 | 195 | let defs_of_atd_module l = 196 | List.map (function `Type def -> def_of_atd def) l 197 | 198 | let defs_of_atd_modules l = 199 | List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module l)) l 200 | -------------------------------------------------------------------------------- /src/ag_ob_run.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | Runtime library 4 | *) 5 | 6 | open Printf 7 | 8 | exception Error of string 9 | 10 | (* 11 | Error messages 12 | *) 13 | let error s = raise (Error s) 14 | 15 | let read_error () = 16 | error "Read error" 17 | 18 | let read_error_at ib = 19 | error (sprintf "Read error (%i)" ib.Bi_inbuf.i_pos) 20 | 21 | let tag_error tag s = 22 | error (sprintf "Found wrong tag %i for %s" tag s) 23 | 24 | let unsupported_variant h has_arg = 25 | error (sprintf "Unsupported variant (hash=%i, arg=%B)" h has_arg) 26 | 27 | 28 | let missing_tuple_fields len req_fields = 29 | let missing = 30 | List.fold_right ( 31 | fun i acc -> if i >= len then i :: acc else acc 32 | ) req_fields [] 33 | in 34 | error (sprintf "Missing tuple field%s %s" 35 | (if List.length missing > 1 then "s" else "") 36 | (String.concat ", " (List.map string_of_int missing))) 37 | 38 | 39 | let missing_fields bit_fields field_names = 40 | let acc = ref [] in 41 | for z = Array.length field_names - 1 downto 0 do 42 | let i = z / 31 in 43 | let j = z mod 31 in 44 | if bit_fields.(i) land (1 lsl j) = 0 then 45 | acc := field_names.(z) :: !acc 46 | done; 47 | error (sprintf "Missing record field%s %s" 48 | (if List.length !acc > 1 then "s" else "") 49 | (String.concat ", " !acc)) 50 | 51 | 52 | (* 53 | Readers 54 | *) 55 | 56 | let get_unit_reader tag = 57 | if tag = Bi_io.unit_tag then 58 | Bi_io.read_untagged_unit 59 | else 60 | tag_error tag "unit" 61 | 62 | let read_unit ib = 63 | if Bi_io.read_tag ib = Bi_io.unit_tag then 64 | Bi_io.read_untagged_unit ib 65 | else 66 | read_error_at ib 67 | 68 | let get_bool_reader tag = 69 | if tag = Bi_io.bool_tag then 70 | Bi_io.read_untagged_bool 71 | else 72 | tag_error tag "bool" 73 | 74 | let read_bool ib = 75 | if Bi_io.read_tag ib = Bi_io.bool_tag then 76 | Bi_io.read_untagged_bool ib 77 | else 78 | read_error_at ib 79 | 80 | let get_int_reader tag = 81 | match tag with 82 | 1 -> Bi_io.read_untagged_int8 83 | | 2 -> Bi_io.read_untagged_int16 84 | | 16 -> Bi_io.read_untagged_uvint 85 | | 17 -> Bi_io.read_untagged_svint 86 | | _ -> tag_error tag "int" 87 | 88 | let read_int ib = 89 | match Bi_io.read_tag ib with 90 | 1 -> Bi_io.read_untagged_int8 ib 91 | | 2 -> Bi_io.read_untagged_int16 ib 92 | | 16 -> Bi_io.read_untagged_uvint ib 93 | | 17 -> Bi_io.read_untagged_svint ib 94 | | _ -> read_error_at ib 95 | 96 | let get_char_reader tag = 97 | if tag = Bi_io.int8_tag then 98 | Bi_io.read_untagged_char 99 | else 100 | tag_error tag "char" 101 | 102 | let read_char ib = 103 | if Bi_io.read_tag ib = Bi_io.int8_tag then 104 | Bi_io.read_untagged_char ib 105 | else 106 | read_error_at ib 107 | 108 | let get_int16_reader tag = 109 | if tag = Bi_io.int16_tag then 110 | Bi_io.read_untagged_int16 111 | else 112 | tag_error tag "int16" 113 | 114 | let read_int16 ib = 115 | if Bi_io.read_tag ib = Bi_io.int16_tag then 116 | Bi_io.read_untagged_int16 ib 117 | else 118 | read_error_at ib 119 | 120 | let get_int32_reader tag = 121 | if tag = Bi_io.int32_tag then 122 | Bi_io.read_untagged_int32 123 | else 124 | tag_error tag "int32" 125 | 126 | let read_int32 ib = 127 | if Bi_io.read_tag ib = Bi_io.int32_tag then 128 | Bi_io.read_untagged_int32 ib 129 | else 130 | read_error_at ib 131 | 132 | let get_int64_reader tag = 133 | if tag = Bi_io.int64_tag then 134 | Bi_io.read_untagged_int64 135 | else 136 | tag_error tag "int64" 137 | 138 | let read_int64 ib = 139 | if Bi_io.read_tag ib = Bi_io.int64_tag then 140 | Bi_io.read_untagged_int64 ib 141 | else 142 | read_error_at ib 143 | 144 | let get_float32_reader tag = 145 | if tag = Bi_io.float32_tag then 146 | Bi_io.read_untagged_float32 147 | else 148 | tag_error tag "float32" 149 | 150 | let get_float64_reader tag = 151 | if tag = Bi_io.float64_tag then 152 | Bi_io.read_untagged_float64 153 | else 154 | tag_error tag "float64" 155 | 156 | let get_float_reader = get_float64_reader 157 | 158 | let read_float32 ib = 159 | if Bi_io.read_tag ib = Bi_io.float32_tag then 160 | Bi_io.read_untagged_float32 ib 161 | else 162 | read_error_at ib 163 | 164 | let read_float64 ib = 165 | if Bi_io.read_tag ib = Bi_io.float64_tag then 166 | Bi_io.read_untagged_float64 ib 167 | else 168 | read_error_at ib 169 | 170 | let read_float = read_float64 171 | 172 | let get_string_reader tag = 173 | if tag = Bi_io.string_tag then 174 | Bi_io.read_untagged_string 175 | else 176 | tag_error tag "string" 177 | 178 | let read_string ib = 179 | if Bi_io.read_tag ib = Bi_io.string_tag then 180 | Bi_io.read_untagged_string ib 181 | else 182 | read_error_at ib 183 | 184 | let read_array_value get_reader ib = 185 | let len = Bi_vint.read_uvint ib in 186 | if len = 0 then [| |] 187 | else 188 | let reader = get_reader (Bi_io.read_tag ib) in 189 | let a = Array.make len (reader ib) in 190 | for i = 1 to len - 1 do 191 | Array.unsafe_set a i (reader ib) 192 | done; 193 | a 194 | 195 | let read_list_value get_reader ib = 196 | Array.to_list (read_array_value get_reader ib) 197 | 198 | let get_array_reader get_reader tag = 199 | if tag = Bi_io.array_tag then 200 | read_array_value get_reader 201 | else 202 | tag_error tag "array" 203 | 204 | let get_list_reader get_reader tag = 205 | if tag = Bi_io.array_tag then 206 | fun ib -> Array.to_list (read_array_value get_reader ib) 207 | else 208 | tag_error tag "list" 209 | 210 | let read_array get_reader ib = 211 | if Bi_io.read_tag ib = Bi_io.array_tag then 212 | read_array_value get_reader ib 213 | else 214 | read_error_at ib 215 | 216 | let read_list read ib = 217 | Array.to_list (read_array read ib) 218 | 219 | 220 | (* 221 | Writers 222 | *) 223 | 224 | let write_tagged tag write buf x = 225 | Bi_io.write_tag buf tag; 226 | write buf x 227 | 228 | let write_untagged_option write buf x = 229 | match x with 230 | None -> Bi_io.write_numtag buf 0 false 231 | | Some x -> 232 | Bi_io.write_numtag buf 0 true; 233 | write buf x 234 | 235 | let write_option write buf x = 236 | Bi_io.write_tag buf Bi_io.num_variant_tag; 237 | write_untagged_option write buf x 238 | 239 | let array_init2 len x f = 240 | if len = 0 then [| |] 241 | else 242 | let a = Array.make len (f 0 x) in 243 | for i = 1 to len - 1 do 244 | Array.unsafe_set a i (f i x) 245 | done; 246 | a 247 | 248 | let array_init3 len x y f = 249 | if len = 0 then [| |] 250 | else 251 | let a = Array.make len (f 0 x y) in 252 | for i = 1 to len - 1 do 253 | Array.unsafe_set a i (f i x y) 254 | done; 255 | a 256 | 257 | let array_iter2 f x a = 258 | for i = 0 to Array.length a - 1 do 259 | f x (Array.unsafe_get a i) 260 | done 261 | 262 | let array_iter3 f x y a = 263 | for i = 0 to Array.length a - 1 do 264 | f x y (Array.unsafe_get a i) 265 | done 266 | 267 | 268 | let rec list_iter2 f x = function 269 | [] -> () 270 | | y :: l -> 271 | f x y; 272 | list_iter2 f x l 273 | 274 | let rec list_iter3 f x y = function 275 | [] -> () 276 | | z :: l -> 277 | f x y z; 278 | list_iter3 f x y l 279 | 280 | 281 | let write_untagged_array cell_tag write buf a = 282 | let len = Array.length a in 283 | Bi_vint.write_uvint buf len; 284 | if len > 0 then ( 285 | Bi_io.write_tag buf cell_tag; 286 | array_iter2 write buf a 287 | ) 288 | 289 | let write_array cell_tag write buf a = 290 | Bi_io.write_tag buf Bi_io.array_tag; 291 | write_untagged_array cell_tag write buf a 292 | 293 | let write_untagged_list cell_tag write buf l = 294 | let len = List.length l in 295 | Bi_vint.write_uvint buf len; 296 | if len > 0 then ( 297 | Bi_io.write_tag buf cell_tag; 298 | list_iter2 write buf l 299 | ) 300 | 301 | let write_list cell_tag write buf l = 302 | Bi_io.write_tag buf Bi_io.array_tag; 303 | write_untagged_list cell_tag write buf l 304 | 305 | (* 306 | shortcut for getting the tag of a polymorphic variant since 307 | biniou uses the same representation 308 | (usefulness?) 309 | *) 310 | let get_poly_tag (x : [> ]) = 311 | let r = Obj.repr x in 312 | if Obj.is_block r then 313 | (Obj.obj (Obj.field r 0) : int) 314 | else 315 | (Obj.obj r : int) 316 | 317 | (* We want an identity function that is not inlined *) 318 | type identity_t = { mutable _identity : 'a. 'a -> 'a } 319 | let identity_ref = { _identity = (fun x -> x) } 320 | let identity x = identity_ref._identity x 321 | 322 | (* 323 | Checking at runtime that our assumptions on unspecified compiler behavior 324 | still hold. 325 | *) 326 | 327 | type t = { 328 | _a : int option; 329 | _b : int; 330 | } 331 | 332 | let create () = 333 | { { _a = None; _b = Array.length Sys.argv } with _a = None } 334 | 335 | let test () = 336 | let r = create () in 337 | let v = Some 17 in 338 | Obj.set_field (Obj.repr r) 0 (Obj.repr v); 339 | let safe_r = identity r in 340 | (* r._a is inlined by ocamlopt and equals None 341 | because the field is supposed to be immutable. *) 342 | assert (safe_r._a = v) 343 | 344 | let () = test () 345 | 346 | (************************************) 347 | -------------------------------------------------------------------------------- /src/ag_ob_spe.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | Optimization of the biniou representation 4 | *) 5 | 6 | open Ag_mapping 7 | open Ag_ob_mapping 8 | 9 | let get_table_info deref x = 10 | match deref x with 11 | `Record y -> y 12 | | _ -> 13 | Ag_error.error (Atd_ast.loc_of_type_expr x) "Not a record type" 14 | -------------------------------------------------------------------------------- /src/ag_ocaml.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | Translation from ATD types into OCaml types and pretty-printing. 4 | 5 | This is derived from the ATD pretty-printer (atd_print.ml). 6 | *) 7 | 8 | open Printf 9 | 10 | open Easy_format 11 | open Atd_ast 12 | open Ag_mapping 13 | 14 | 15 | (* Type mapping from ATD to OCaml *) 16 | 17 | type atd_ocaml_sum = [ `Classic | `Poly ] 18 | type atd_ocaml_record = [ `Record | `Object ] 19 | 20 | type atd_ocaml_int = [ `Int | `Char | `Int32 | `Int64 | `Float ] 21 | type atd_ocaml_list = [ `List | `Array ] 22 | 23 | type atd_ocaml_wrap = { 24 | ocaml_wrap_t : string; 25 | ocaml_wrap : string; 26 | ocaml_unwrap : string; 27 | } 28 | 29 | type atd_ocaml_field = { 30 | ocaml_default : string option; 31 | ocaml_fname : string; 32 | ocaml_mutable : bool; 33 | ocaml_fdoc : Ag_doc.doc option; 34 | } 35 | 36 | type atd_ocaml_variant = { 37 | ocaml_cons : string; 38 | ocaml_vdoc : Ag_doc.doc option; 39 | } 40 | 41 | type atd_ocaml_def = { 42 | ocaml_predef : bool; 43 | ocaml_ddoc : Ag_doc.doc option; 44 | } 45 | 46 | type atd_ocaml_repr = 47 | [ 48 | | `Unit 49 | | `Bool 50 | | `Int of atd_ocaml_int 51 | | `Float 52 | | `String 53 | | `Sum of atd_ocaml_sum 54 | | `Record of atd_ocaml_record 55 | | `Tuple 56 | | `List of atd_ocaml_list 57 | | `Option 58 | | `Nullable 59 | | `Wrap of atd_ocaml_wrap option 60 | | `Name of string 61 | | `External of (string * string * string) 62 | (* 63 | (module providing the type, 64 | module providing everything else, 65 | type name) 66 | *) 67 | 68 | | `Cell of atd_ocaml_field 69 | | `Field of atd_ocaml_field 70 | | `Variant of atd_ocaml_variant 71 | | `Def of atd_ocaml_def 72 | ] 73 | 74 | type target = [ `Default | `Biniou | `Json | `Validate ] 75 | 76 | 77 | let ocaml_int_of_string s : atd_ocaml_int option = 78 | match s with 79 | "int" -> Some `Int 80 | | "char" -> Some `Char 81 | | "int32" -> Some `Int32 82 | | "int64" -> Some `Int64 83 | | "float" -> Some `Float 84 | | _ -> None 85 | 86 | let string_of_ocaml_int (x : atd_ocaml_int) = 87 | match x with 88 | `Int -> "int" 89 | | `Char -> "Char.t" 90 | | `Int32 -> "Int32.t" 91 | | `Int64 -> "Int64.t" 92 | | `Float -> "float" 93 | 94 | let ocaml_sum_of_string s : atd_ocaml_sum option = 95 | match s with 96 | "classic" -> Some `Classic 97 | | "poly" -> Some `Poly 98 | | s -> None 99 | 100 | let ocaml_record_of_string s : atd_ocaml_record option = 101 | match s with 102 | "record" -> Some `Record 103 | | "object" -> Some `Object 104 | | s -> None 105 | 106 | let ocaml_list_of_string s : atd_ocaml_list option = 107 | match s with 108 | "list" -> Some `List 109 | | "array" -> Some `Array 110 | | s -> None 111 | 112 | let string_of_ocaml_list (x : atd_ocaml_list) = 113 | match x with 114 | `List -> "list" 115 | | `Array -> "Ag_util.ocaml_array" 116 | 117 | let get_ocaml_int an = 118 | Atd_annot.get_field ocaml_int_of_string `Int ["ocaml"] "repr" an 119 | 120 | let get_ocaml_type_path atd_name an = 121 | let x = 122 | match atd_name with 123 | "unit" -> `Unit 124 | | "bool" -> `Bool 125 | | "int" -> `Int (get_ocaml_int an) 126 | | "float" -> `Float 127 | | "string" -> `String 128 | | s -> `Name s 129 | in 130 | match x with 131 | `Unit -> "unit" 132 | | `Bool -> "bool" 133 | | `Int x -> string_of_ocaml_int x 134 | | `Float -> "float" 135 | | `String -> "string" 136 | | `Name s -> s 137 | 138 | let path_of_target (target : target) = 139 | match target with 140 | `Default -> [ "ocaml" ] 141 | | `Biniou -> [ "ocaml_biniou"; "ocaml" ] 142 | | `Json -> [ "ocaml_json"; "ocaml" ] 143 | | `Validate -> [ "ocaml_validate"; "ocaml" ] 144 | 145 | let get_ocaml_sum an = 146 | Atd_annot.get_field ocaml_sum_of_string `Poly ["ocaml"] "repr" an 147 | 148 | let get_ocaml_field_prefix an = 149 | Atd_annot.get_field (fun s -> Some s) "" ["ocaml"] "field_prefix" an 150 | 151 | let get_ocaml_record an = 152 | Atd_annot.get_field ocaml_record_of_string `Record ["ocaml"] "repr" an 153 | 154 | let get_ocaml_list an = 155 | Atd_annot.get_field ocaml_list_of_string `List ["ocaml"] "repr" an 156 | 157 | let get_ocaml_wrap loc an = 158 | let module_ = 159 | Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "module" an in 160 | let default field = 161 | match module_ with 162 | None -> None 163 | | Some s -> Some (sprintf "%s.%s" s field) 164 | in 165 | let t = 166 | Atd_annot.get_field (fun s -> Some (Some s)) 167 | (default "t") ["ocaml"] "t" an 168 | in 169 | let wrap = 170 | Atd_annot.get_field (fun s -> Some (Some s)) 171 | (default "wrap") ["ocaml"] "wrap" an 172 | in 173 | let unwrap = 174 | Atd_annot.get_field (fun s -> Some (Some s)) 175 | (default "unwrap") ["ocaml"] "unwrap" an 176 | in 177 | match t, wrap, unwrap with 178 | None, None, None -> None 179 | | Some t, Some wrap, Some unwrap -> 180 | Some { ocaml_wrap_t = t; ocaml_wrap = wrap; ocaml_unwrap = unwrap } 181 | | _ -> 182 | Ag_error.error loc "Incomplete annotation. Missing t, wrap or unwrap" 183 | 184 | let get_ocaml_cons default an = 185 | Atd_annot.get_field (fun s -> Some s) default ["ocaml"] "name" an 186 | 187 | let get_ocaml_fname default an = 188 | Atd_annot.get_field (fun s -> Some s) default ["ocaml"] "name" an 189 | 190 | let get_ocaml_default an = 191 | Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "default" an 192 | 193 | let get_ocaml_mutable an = 194 | Atd_annot.get_flag ["ocaml"] "mutable" an 195 | 196 | let get_ocaml_predef target an = 197 | let path = path_of_target target in 198 | Atd_annot.get_flag path "predef" an 199 | 200 | let get_ocaml_module target an = 201 | let path = path_of_target target in 202 | let o = Atd_annot.get_field (fun s -> Some (Some s)) None path "module" an in 203 | match o with 204 | Some s -> Some (s, s) 205 | | None -> 206 | let o = 207 | Atd_annot.get_field (fun s -> Some (Some s)) None path "from" an 208 | in 209 | match o with 210 | None -> None 211 | | Some s -> 212 | let type_module = s ^ "_t" in 213 | let main_module = 214 | match target with 215 | `Default -> type_module 216 | | `Biniou -> s ^ "_b" 217 | | `Json -> s ^ "_j" 218 | | `Validate -> s ^ "_v" 219 | in 220 | Some (type_module, main_module) 221 | 222 | let get_ocaml_t target default an = 223 | let path = path_of_target target in 224 | Atd_annot.get_field (fun s -> Some s) default path "t" an 225 | 226 | let get_ocaml_module_and_t target default_name an = 227 | match get_ocaml_module target an with 228 | None -> None 229 | | Some (type_module, main_module) -> 230 | Some (type_module, main_module, get_ocaml_t target default_name an) 231 | 232 | 233 | (* 234 | OCaml syntax tree 235 | *) 236 | type ocaml_type_param = string list 237 | 238 | type ocaml_expr = 239 | [ `Sum of (atd_ocaml_sum * ocaml_variant list) 240 | | `Record of (atd_ocaml_record * ocaml_field list) 241 | | `Tuple of ocaml_expr list 242 | | `Name of (string * ocaml_expr list) 243 | | `Tvar of string 244 | ] 245 | 246 | and ocaml_variant = 247 | string * ocaml_expr option * Ag_doc.doc option 248 | 249 | and ocaml_field = 250 | (string * bool (* is mutable? *)) * ocaml_expr * Ag_doc.doc option 251 | 252 | type ocaml_def = { 253 | o_def_name : (string * ocaml_type_param); 254 | o_def_alias : (string * ocaml_type_param) option; 255 | o_def_expr : ocaml_expr option; 256 | o_def_doc : Ag_doc.doc option 257 | } 258 | 259 | type ocaml_module_item = 260 | [ `Type of ocaml_def ] 261 | 262 | type ocaml_module_body = ocaml_module_item list 263 | 264 | 265 | 266 | (* 267 | Mapping from ATD to OCaml 268 | *) 269 | 270 | let omap f = function None -> None | Some x -> Some (f x) 271 | 272 | let rec map_expr (x : type_expr) : ocaml_expr = 273 | match x with 274 | `Sum (loc, l, an) -> 275 | let kind = get_ocaml_sum an in 276 | `Sum (kind, List.map map_variant l) 277 | | `Record (loc, l, an) -> 278 | let kind = get_ocaml_record an in 279 | let field_prefix = get_ocaml_field_prefix an in 280 | if l = [] then 281 | Ag_error.error loc "Empty record (not valid in OCaml)" 282 | else 283 | `Record (kind, List.map (map_field field_prefix) l) 284 | | `Tuple (loc, l, an) -> 285 | `Tuple (List.map (fun (_, x, _) -> map_expr x) l) 286 | | `List (loc, x, an) -> 287 | let s = string_of_ocaml_list (get_ocaml_list an) in 288 | `Name (s, [map_expr x]) 289 | | `Option (loc, x, an) -> 290 | `Name ("option", [map_expr x]) 291 | | `Nullable (loc, x, an) -> 292 | `Name ("option", [map_expr x]) 293 | | `Shared (loc, x, a) -> 294 | failwith "Sharing is not supported" 295 | | `Wrap (loc, x, a) -> 296 | (match get_ocaml_wrap loc a with 297 | None -> map_expr x 298 | | Some { ocaml_wrap_t } -> `Name (ocaml_wrap_t, []) 299 | ) 300 | | `Name (loc, (loc2, s, l), an) -> 301 | let s = get_ocaml_type_path s an in 302 | `Name (s, List.map map_expr l) 303 | | `Tvar (loc, s) -> 304 | `Tvar s 305 | 306 | and map_variant (x : variant) : ocaml_variant = 307 | match x with 308 | `Inherit _ -> assert false 309 | | `Variant (loc, (s, an), o) -> 310 | let s = get_ocaml_cons s an in 311 | (s, omap map_expr o, Ag_doc.get_doc loc an) 312 | 313 | and map_field ocaml_field_prefix (x : field) : ocaml_field = 314 | match x with 315 | `Inherit _ -> assert false 316 | | `Field (loc, (atd_fname, fkind, an), x) -> 317 | let ocaml_fname = 318 | get_ocaml_fname (ocaml_field_prefix ^ atd_fname) an in 319 | let fname = 320 | if ocaml_fname = atd_fname then ocaml_fname 321 | else sprintf "%s (*atd %s *)" ocaml_fname atd_fname 322 | in 323 | let is_mutable = get_ocaml_mutable an in 324 | ((fname, is_mutable), map_expr x, Ag_doc.get_doc loc an) 325 | 326 | let map_def 327 | ~(target : target) 328 | ~(type_aliases : string option) 329 | ((loc, (s, param, an1), x) : type_def) : ocaml_def option = 330 | let is_predef = get_ocaml_predef target an1 in 331 | let is_abstract = Ag_mapping.is_abstract x in 332 | let define_alias = 333 | if is_predef || is_abstract || type_aliases <> None then 334 | match get_ocaml_module_and_t target s an1, type_aliases with 335 | Some (types_module, main_module, s), _ -> Some (types_module, s) 336 | | None, Some types_module -> Some (types_module, s) 337 | 338 | | None, None -> None 339 | else 340 | None 341 | in 342 | if is_predef && define_alias = None then 343 | None 344 | else 345 | let an2 = Atd_ast.annot_of_type_expr x in 346 | let an = an1 @ an2 in 347 | let doc = Ag_doc.get_doc loc an in 348 | let alias, x = 349 | match define_alias with 350 | None -> 351 | if is_abstract then (None, None) 352 | else (None, Some (map_expr x)) 353 | | Some (module_path, ext_name) -> 354 | let alias = Some (module_path ^ "." ^ ext_name, param) in 355 | let x = 356 | match map_expr x with 357 | `Sum (`Classic, _) 358 | | `Record (`Record, _) as x -> Some x 359 | | _ -> None 360 | in 361 | (alias, x) 362 | in 363 | if x = None && alias = None then 364 | None 365 | else 366 | Some { 367 | o_def_name = (s, param); 368 | o_def_alias = alias; 369 | o_def_expr = x; 370 | o_def_doc = doc 371 | } 372 | 373 | let rec select f = function 374 | [] -> [] 375 | | x :: l -> 376 | match f x with 377 | None -> select f l 378 | | Some y -> y :: select f l 379 | 380 | let map_module ~target ~type_aliases (l : module_body) : ocaml_module_body = 381 | select ( 382 | fun (`Type td) -> 383 | match map_def ~target ~type_aliases td with 384 | None -> None 385 | | Some x -> Some (`Type x) 386 | ) l 387 | 388 | 389 | (* 390 | Mapping from Ag_mapping to OCaml 391 | *) 392 | 393 | 394 | let rec ocaml_of_expr_mapping (x : (atd_ocaml_repr, _) mapping) : ocaml_expr = 395 | match x with 396 | `Unit (loc, `Unit, _) -> `Name ("unit", []) 397 | | `Bool (loc, `Bool, _) -> `Name ("bool", []) 398 | | `Int (loc, `Int x, _) -> `Name (string_of_ocaml_int x, []) 399 | | `Float (loc, `Float, _) -> `Name ("float", []) 400 | | `String (loc, `String, _) -> `Name ("string", []) 401 | | `Sum (loc, a, `Sum kind, _) -> 402 | let l = Array.to_list a in 403 | `Sum (kind, List.map ocaml_of_variant_mapping l) 404 | | `Record (loc, a, `Record o, _) -> 405 | let l = Array.to_list a in 406 | `Record (`Record, List.map ocaml_of_field_mapping l) 407 | | `Tuple (loc, a, o, _) -> 408 | let l = Array.to_list a in 409 | `Tuple (List.map (fun x -> ocaml_of_expr_mapping x.cel_value) l) 410 | | `List (loc, x, `List kind, _) -> 411 | `Name (string_of_ocaml_list kind, [ocaml_of_expr_mapping x]) 412 | | `Option (loc, x, `Option, _) -> 413 | `Name ("option", [ocaml_of_expr_mapping x]) 414 | | `Nullable (loc, x, `Nullable, _) -> 415 | `Name ("option", [ocaml_of_expr_mapping x]) 416 | | `Wrap _ -> 417 | assert false 418 | | `Name (loc, s, l, _, _) -> 419 | `Name (s, List.map ocaml_of_expr_mapping l) 420 | | `Tvar (loc, s) -> 421 | `Tvar s 422 | | _ -> assert false 423 | 424 | and ocaml_of_variant_mapping x = 425 | let o = 426 | match x.var_arepr with 427 | `Variant o -> o 428 | | _ -> assert false 429 | in 430 | (o.ocaml_cons, omap ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc) 431 | 432 | and ocaml_of_field_mapping x = 433 | let o = 434 | match x.f_arepr with 435 | `Field o -> o 436 | | _ -> assert false 437 | in 438 | let v = ocaml_of_expr_mapping x.f_value in 439 | ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc) 440 | 441 | 442 | (* 443 | Pretty-printing 444 | *) 445 | 446 | 447 | 448 | let rlist = { list with 449 | wrap_body = `Force_breaks; 450 | indent_body = 0; 451 | align_closing = false; 452 | space_after_opening = false; 453 | space_before_closing = false 454 | } 455 | 456 | let plist = { list with 457 | align_closing = false; 458 | space_after_opening = false; 459 | space_before_closing = false } 460 | 461 | let hlist = { list with wrap_body = `No_breaks } 462 | let shlist = { hlist with 463 | stick_to_label = false; 464 | space_after_opening = false; 465 | space_before_closing = false } 466 | let shlist0 = { shlist with space_after_separator = false } 467 | 468 | let llist = { 469 | list with 470 | separators_stick_left = false; 471 | space_before_separator = true; 472 | space_after_separator = true 473 | } 474 | 475 | let lplist = { 476 | llist with 477 | space_after_opening = false; 478 | space_before_closing = false 479 | } 480 | 481 | let vseq = { 482 | list with 483 | indent_body = 0; 484 | wrap_body = `Force_breaks; 485 | } 486 | 487 | 488 | let vlist1 = { list with stick_to_label = false } 489 | 490 | let vlist = { 491 | vlist1 with 492 | wrap_body = `Force_breaks; 493 | } 494 | 495 | 496 | let label0 = { label with space_after_label = false } 497 | 498 | let make_atom s = Atom (s, atom) 499 | 500 | let horizontal_sequence l = List (("", "", "", shlist), l) 501 | let horizontal_sequence0 l = List (("", "", "", shlist0), l) 502 | 503 | let rec insert sep = function 504 | [] | [_] as l -> l 505 | | x :: l -> x :: sep @ insert sep l 506 | 507 | let rec insert2 f = function 508 | [] | [_] as l -> l 509 | | x :: (y :: _ as l) -> x :: f x y @ insert2 f l 510 | 511 | 512 | let vertical_sequence ?(skip_lines = 0) l = 513 | let l = 514 | if skip_lines = 0 then l 515 | else 516 | let sep = 517 | Array.to_list (Array.init skip_lines (fun _ -> (Atom ("", atom)))) 518 | in 519 | insert sep l 520 | in 521 | List (("", "", "", rlist), l) 522 | 523 | let escape f s = 524 | let buf = Buffer.create (2 * String.length s) in 525 | for i = 0 to String.length s - 1 do 526 | let c = s.[i] in 527 | match f c with 528 | None -> Buffer.add_char buf c 529 | | Some s -> Buffer.add_string buf s 530 | done; 531 | Buffer.contents buf 532 | 533 | let ocamldoc_escape s = 534 | let esc = function 535 | '{' | '}' | '[' | ']' | '@' | '\\' as c -> Some (sprintf "\\%c" c) 536 | | _ -> None 537 | in 538 | escape esc s 539 | 540 | let ocamldoc_verbatim_escape s = 541 | let esc = function 542 | '{' | '}' | '\\' as c -> Some (sprintf "\\%c" c) 543 | | _ -> None 544 | in 545 | escape esc s 546 | 547 | let split = Str.split (Str.regexp " ") 548 | 549 | 550 | let make_ocamldoc_block = function 551 | `Pre s -> Atom ("\n{v\n" ^ ocamldoc_verbatim_escape s ^ "\nv}", atom) 552 | | `Before_paragraph -> Atom ("", atom) 553 | | `Paragraph l -> 554 | let l = List.map ( 555 | function 556 | `Text s -> ocamldoc_escape s 557 | | `Code s -> "[" ^ ocamldoc_escape s ^ "]" 558 | ) l 559 | in 560 | let words = split (String.concat "" l) in 561 | let atoms = List.map (fun s -> Atom (s, atom)) words in 562 | List (("", "", "", plist), atoms) 563 | 564 | let make_ocamldoc_blocks (l : Ag_doc.block list) = 565 | let l = 566 | insert2 ( 567 | fun x y -> 568 | match y with 569 | `Paragraph _ -> [`Before_paragraph] 570 | | `Pre _ -> [] 571 | | _ -> assert false 572 | ) (l :> [ Ag_doc.block | `Before_paragraph ] list) 573 | in 574 | List.map make_ocamldoc_block l 575 | 576 | 577 | let make_ocamldoc_comment (`Text l) = 578 | let blocks = make_ocamldoc_blocks l in 579 | let xlist = 580 | match l with 581 | [] | [_] -> vlist1 582 | | _ -> vlist 583 | in 584 | List (("(**", "", "*)", xlist), blocks) 585 | 586 | let prepend_ocamldoc_comment doc x = 587 | match doc with 588 | None -> x 589 | | Some y -> 590 | let comment = make_ocamldoc_comment y in 591 | List (("", "", "", rlist), [comment;x]) 592 | 593 | let append_ocamldoc_comment x doc = 594 | match doc with 595 | None -> x 596 | | Some y -> 597 | let comment = make_ocamldoc_comment y in 598 | Label ((x, label), comment) 599 | 600 | let format_pp_conv_node node = function 601 | | `Camlp4 [] 602 | | `Ppx [] -> node 603 | | converters -> 604 | let converters = 605 | match converters with 606 | | `Ppx cs -> "[@@deriving " ^ (String.concat ", " cs) ^ "]" 607 | | `Camlp4 cs -> "with " ^ (String.concat ", " cs) in 608 | Label ((node, label), make_atom converters) 609 | 610 | let rec format_module_item pp_convs 611 | is_first (`Type def : ocaml_module_item) = 612 | let type_ = if is_first then "type" else "and" in 613 | let s, param = def.o_def_name in 614 | let alias = def.o_def_alias in 615 | let expr = def.o_def_expr in 616 | let doc = def.o_def_doc in 617 | let append_if b s1 s2 = 618 | if b then s1 ^ s2 619 | else s1 620 | in 621 | let part1 = 622 | horizontal_sequence ( 623 | make_atom type_ :: 624 | prepend_type_param param 625 | [ make_atom (append_if (alias <> None || expr <> None) s " =") ] 626 | ) 627 | in 628 | let part12 = 629 | match alias with 630 | None -> part1 631 | | Some (name, param) -> 632 | let right = 633 | horizontal_sequence ( 634 | prepend_type_param param 635 | [ make_atom (append_if (expr <> None) name " =") ] 636 | ) 637 | in 638 | Label ( 639 | (part1, label), 640 | right 641 | ) 642 | in 643 | let part123 = 644 | match expr with 645 | None -> part12 646 | 647 | | Some t -> 648 | Label ( 649 | (part12, label), 650 | format_type_expr t 651 | ) 652 | in 653 | format_pp_conv_node (prepend_ocamldoc_comment doc part123) pp_convs 654 | 655 | 656 | and prepend_type_param l tl = 657 | match l with 658 | [] -> tl 659 | | _ -> 660 | let make_var s = make_atom ("'" ^ s) in 661 | let x = 662 | match l with 663 | [s] -> make_var s 664 | | l -> List (("(", ",", ")", plist), List.map make_var l) 665 | in 666 | x :: tl 667 | 668 | and prepend_type_args l tl = 669 | match l with 670 | [] -> tl 671 | | _ -> 672 | let x = 673 | match l with 674 | [t] -> format_type_expr t 675 | | l -> List (("(", ",", ")", plist), List.map format_type_expr l) 676 | in 677 | x :: tl 678 | 679 | and format_type_expr x = 680 | match x with 681 | `Sum (kind, l) -> 682 | let op, cl = 683 | match kind with 684 | `Classic -> "", "" 685 | | `Poly -> "[", "]" 686 | in 687 | List ( 688 | (op, "|", cl, llist), 689 | List.map (format_variant kind) l 690 | ) 691 | | `Record (kind, l) -> 692 | let op, cl = 693 | match kind with 694 | `Record -> "{", "}" 695 | | `Object -> "<", ">" 696 | in 697 | List ( 698 | (op, ";", cl, list), 699 | List.map format_field l 700 | ) 701 | | `Tuple l -> 702 | List ( 703 | ("(", "*", ")", lplist), 704 | List.map format_type_expr l 705 | ) 706 | | `Name (name, args) -> 707 | format_type_name name args 708 | 709 | | `Tvar name -> 710 | make_atom ("'" ^ name) 711 | 712 | and format_type_name name args = 713 | horizontal_sequence (prepend_type_args args [ make_atom name ]) 714 | 715 | and format_field ((s, is_mutable), t, doc) = 716 | let l = 717 | let l = [make_atom (s ^ ":")] in 718 | if is_mutable then 719 | make_atom "mutable" :: l 720 | else l 721 | in 722 | let field = 723 | Label ( 724 | (horizontal_sequence l, label), 725 | format_type_expr t 726 | ) 727 | in 728 | append_ocamldoc_comment field doc 729 | 730 | and format_variant kind (s, o, doc) = 731 | let s = 732 | match kind with 733 | `Classic -> s 734 | | `Poly -> "`" ^ s 735 | in 736 | let cons = make_atom s in 737 | let variant = 738 | match o with 739 | None -> cons 740 | | Some t -> 741 | Label ( 742 | (cons, label), 743 | Label ( 744 | (make_atom "of", label), 745 | format_type_expr t 746 | ) 747 | ) 748 | in 749 | append_ocamldoc_comment variant doc 750 | 751 | let format_module_items pp_convs is_rec (l : ocaml_module_body) = 752 | match l with 753 | x :: l -> 754 | format_module_item pp_convs true x :: 755 | List.map (fun x -> format_module_item pp_convs false x) l 756 | | [] -> [] 757 | 758 | let format_module_bodies pp_conv (l : (bool * ocaml_module_body) list) = 759 | List.flatten (List.map (fun (is_rec, x) -> format_module_items pp_conv is_rec x) l) 760 | 761 | let format_head (loc, an) = 762 | match Ag_doc.get_doc loc an with 763 | None -> [] 764 | | Some doc -> [make_ocamldoc_comment doc] 765 | 766 | let format_all l = 767 | vertical_sequence ~skip_lines:1 l 768 | 769 | 770 | let ocaml_of_expr x : string = 771 | Easy_format.Pretty.to_string (format_type_expr x) 772 | 773 | let ocaml_of_atd ?(pp_convs=`Ppx []) ~target ~type_aliases 774 | (head, (l : (bool * module_body) list)) : string = 775 | let head = format_head head in 776 | let bodies = 777 | List.map (fun (is_rec, m) -> 778 | (is_rec, map_module ~target ~type_aliases m)) l 779 | in 780 | let body = format_module_bodies pp_convs bodies in 781 | let x = format_all (head @ body) in 782 | Easy_format.Pretty.to_string x 783 | 784 | let unwrap_option deref x = 785 | match deref x with 786 | `Option (_, x, _, _) 787 | | `Nullable (_, x, _, _) -> x 788 | | `Name (loc, s, _, _, _) -> 789 | Ag_error.error loc ("Not an option type: " ^ s) 790 | | x -> 791 | Ag_error.error (loc_of_mapping x) "Not an option type" 792 | 793 | 794 | 795 | let get_implicit_ocaml_default deref x = 796 | match deref x with 797 | `Unit (loc, `Unit, _) -> Some "()" 798 | | `Bool (loc, `Bool, _) -> Some "false" 799 | | `Int (loc, `Int o, _) -> 800 | Some (match o with 801 | `Int -> "0" 802 | | `Char -> "'\000'" 803 | | `Int32 -> "0l" 804 | | `Int64 -> "0L" 805 | | `Float -> "0.") 806 | | `Float (loc, `Float, _) -> Some "0.0" 807 | | `String (loc, `String, _) -> Some "\"\"" 808 | | `List (loc, x, `List `List, _) -> Some "[]" 809 | | `List (loc, x, `List `Array, _) -> Some "[||]" 810 | | `Option (loc, x, `Option, _) -> Some "None" 811 | | `Nullable (loc, x, `Nullable, _) -> Some "None" 812 | | _ -> None 813 | 814 | 815 | let map_record_creator_field deref x = 816 | let o = 817 | match x.f_arepr with 818 | `Field o -> o 819 | | _ -> assert false 820 | in 821 | let fname = o.ocaml_fname in 822 | let impl2 = sprintf "\n %s = %s;" fname fname in 823 | match x.f_kind with 824 | `Required -> 825 | let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in 826 | let intf = sprintf "\n %s: %s ->" fname t in 827 | let impl1 = sprintf "\n ~%s" fname in 828 | intf, impl1, impl2 829 | 830 | | `Optional -> 831 | let x = unwrap_option deref x.f_value in 832 | let t = ocaml_of_expr (ocaml_of_expr_mapping x) in 833 | let intf = sprintf "\n ?%s: %s ->" fname t in 834 | let impl1 = sprintf "\n ?%s" fname in 835 | intf, impl1, impl2 836 | 837 | | `With_default -> 838 | let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in 839 | let intf = sprintf "\n ?%s: %s ->" fname t in 840 | let impl1 = 841 | let default = 842 | match o.ocaml_default with 843 | None -> 844 | (match get_implicit_ocaml_default deref x.f_value with 845 | None -> 846 | Ag_error.error x.f_loc "Missing default field value" 847 | | Some s -> s 848 | ) 849 | | Some s -> s 850 | in 851 | sprintf "\n ?(%s = %s)" fname default 852 | in 853 | intf, impl1, impl2 854 | -------------------------------------------------------------------------------- /src/ag_ocaml.mli: -------------------------------------------------------------------------------- 1 | 2 | type atd_ocaml_sum = [ `Classic | `Poly ] 3 | type atd_ocaml_record = [ `Record | `Object ] 4 | type atd_ocaml_int = [ `Int | `Char | `Int32 | `Int64 | `Float ] 5 | type atd_ocaml_list = [ `List | `Array ] 6 | type target = [ `Default | `Biniou | `Json | `Validate ] 7 | 8 | type atd_ocaml_wrap = { 9 | ocaml_wrap_t : string; 10 | ocaml_wrap : string; 11 | ocaml_unwrap : string; 12 | } 13 | 14 | type atd_ocaml_field = { 15 | ocaml_default : string option; 16 | ocaml_fname : string; 17 | ocaml_mutable : bool; 18 | ocaml_fdoc : Ag_doc.doc option; 19 | } 20 | 21 | type atd_ocaml_variant = { 22 | ocaml_cons : string; 23 | ocaml_vdoc : Ag_doc.doc option; 24 | } 25 | 26 | type atd_ocaml_def = { 27 | ocaml_predef : bool; 28 | ocaml_ddoc : Ag_doc.doc option; 29 | } 30 | 31 | type atd_ocaml_repr = 32 | [ `Unit 33 | | `Bool 34 | | `Int of atd_ocaml_int 35 | | `Float 36 | | `String 37 | | `Sum of atd_ocaml_sum 38 | | `Record of atd_ocaml_record 39 | | `Tuple 40 | | `List of atd_ocaml_list 41 | | `Option 42 | | `Nullable 43 | | `Wrap of atd_ocaml_wrap option 44 | | `Name of string 45 | | `External of (string * string * string) 46 | (* 47 | (module providing the type, 48 | module providing everything else, 49 | type name) 50 | *) 51 | 52 | | `Cell of atd_ocaml_field 53 | | `Field of atd_ocaml_field 54 | | `Variant of atd_ocaml_variant 55 | | `Def of atd_ocaml_def ] 56 | 57 | val get_ocaml_sum : Atd_annot.t -> atd_ocaml_sum 58 | 59 | val get_ocaml_record : Atd_annot.t -> atd_ocaml_record 60 | 61 | val get_ocaml_field_prefix : Atd_annot.t -> string 62 | 63 | val get_ocaml_list : Atd_annot.t -> atd_ocaml_list 64 | 65 | val get_ocaml_wrap : Atd_ast.loc -> Atd_annot.t -> atd_ocaml_wrap option 66 | 67 | val get_ocaml_int : Atd_annot.t -> atd_ocaml_int 68 | 69 | val get_ocaml_default : Atd_annot.t -> string option 70 | 71 | val get_ocaml_cons : string -> Atd_annot.t -> string 72 | 73 | val get_ocaml_fname : string -> Atd_annot.t -> string 74 | 75 | val get_ocaml_mutable : Atd_annot.t -> bool 76 | 77 | val get_ocaml_predef : target -> Atd_annot.t -> bool 78 | 79 | val get_ocaml_module_and_t 80 | : target 81 | -> string 82 | -> Atd_annot.t 83 | -> (string * string * string) option 84 | 85 | 86 | val get_implicit_ocaml_default 87 | : ('a -> 88 | [> `Bool of 'b * [> `Bool ] * 'c 89 | | `Float of 'd * [> `Float ] * 'e 90 | | `Int of 91 | 'f * [> `Int of [< `Char | `Float | `Int | `Int32 | `Int64 ] ] * 'g 92 | | `List of 'h * 'i * [> `List of [> `Array | `List ] ] * 'j 93 | | `Nullable of 'k * 'l * [> `Nullable ] * 'm 94 | | `Option of 'n * 'o * [> `Option ] * 'p 95 | | `String of 'q * [> `String ] * 'r 96 | | `Unit of 's * [> `Unit ] * 't ]) 97 | -> 'a 98 | -> string option 99 | 100 | val unwrap_option 101 | : ('a -> ('b, 'c) Ag_mapping.mapping) 102 | -> 'a 103 | -> ('b, 'c) Ag_mapping.mapping 104 | 105 | val ocaml_of_atd 106 | : ?pp_convs:[ `Camlp4 of string list | `Ppx of string list ] 107 | -> target:target 108 | -> type_aliases:string option 109 | -> (Atd_ast.loc * Atd_ast.annot) * (bool * Atd_ast.module_body) list 110 | -> string 111 | 112 | 113 | val map_record_creator_field 114 | : ((atd_ocaml_repr, 'a) Ag_mapping.mapping 115 | -> (atd_ocaml_repr, 'b) Ag_mapping.mapping) 116 | -> (atd_ocaml_repr, 'a) Ag_mapping.field_mapping 117 | -> string * string * string 118 | -------------------------------------------------------------------------------- /src/ag_oj_emit.mli: -------------------------------------------------------------------------------- 1 | 2 | val make_ocaml_files 3 | :opens:string list 4 | -> with_typedefs:bool 5 | -> with_create:bool 6 | -> with_fundefs:bool 7 | -> all_rec:bool 8 | -> std:bool 9 | -> unknown_field_handler:string option 10 | -> constr_mismatch_handler:string option 11 | -> pos_fname:string option 12 | -> pos_lnum:int option 13 | -> type_aliases:string option 14 | -> force_defaults:bool 15 | -> preprocess_input:string option 16 | -> name_overlap:bool 17 | -> ocaml_version:(int * int) option 18 | -> pp_convs:[ `Camlp4 of string list | `Ppx of string list ] 19 | -> string option 20 | -> [< `Files of string | `Stdout ] 21 | -> unit 22 | -------------------------------------------------------------------------------- /src/ag_oj_mapping.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Atd_ast 3 | open Ag_error 4 | open Ag_mapping 5 | 6 | type o = Ag_ocaml.atd_ocaml_repr 7 | type j = Ag_json.json_repr 8 | 9 | type oj_mapping = 10 | (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.mapping 11 | 12 | type oj_def = 13 | (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.def 14 | 15 | 16 | (* 17 | Translation of the types into the ocaml/json mapping. 18 | *) 19 | 20 | let rec mapping_of_expr (x : type_expr) : oj_mapping = 21 | match x with 22 | `Sum (loc, l, an) -> 23 | let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in 24 | let json_t = `Sum in 25 | `Sum (loc, Array.of_list (List.map mapping_of_variant l), 26 | ocaml_t, json_t) 27 | 28 | | `Record (loc, l, an) -> 29 | let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in 30 | let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in 31 | let json_t = `Record in 32 | `Record (loc, 33 | Array.of_list 34 | (List.map (mapping_of_field ocaml_field_prefix) l), 35 | ocaml_t, json_t) 36 | 37 | | `Tuple (loc, l, an) -> 38 | let ocaml_t = `Tuple in 39 | let json_t = `Tuple in 40 | `Tuple (loc, Array.of_list (List.map mapping_of_cell l), 41 | ocaml_t, json_t) 42 | 43 | | `List (loc, x, an) -> 44 | let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in 45 | let json_t = `List (Ag_json.get_json_list an) in 46 | `List (loc, mapping_of_expr x, ocaml_t, json_t) 47 | 48 | | `Option (loc, x, an) -> 49 | let ocaml_t = `Option in 50 | let json_t = `Option in 51 | `Option (loc, mapping_of_expr x, ocaml_t, json_t) 52 | 53 | | `Nullable (loc, x, an) -> 54 | let ocaml_t = `Nullable in 55 | let json_t = `Nullable in 56 | `Nullable (loc, mapping_of_expr x, ocaml_t, json_t) 57 | 58 | | `Shared (loc, x, an) -> 59 | error loc "Sharing is not supported by the JSON interface" 60 | 61 | | `Wrap (loc, x, an) -> 62 | let ocaml_t = `Wrap (Ag_ocaml.get_ocaml_wrap loc an) in 63 | let json_t = `Wrap in 64 | `Wrap (loc, mapping_of_expr x, ocaml_t, json_t) 65 | 66 | | `Name (loc, (loc2, s, l), an) -> 67 | (match s with 68 | "unit" -> 69 | `Unit (loc, `Unit, `Unit) 70 | | "bool" -> 71 | `Bool (loc, `Bool, `Bool) 72 | | "int" -> 73 | let o = Ag_ocaml.get_ocaml_int an in 74 | `Int (loc, `Int o, `Int) 75 | | "float" -> 76 | let j = Ag_json.get_json_float an in 77 | `Float (loc, `Float, `Float j) 78 | | "string" -> 79 | `String (loc, `String, `String) 80 | | s -> 81 | `Name (loc, s, List.map mapping_of_expr l, None, None) 82 | ) 83 | | `Tvar (loc, s) -> 84 | `Tvar (loc, s) 85 | 86 | and mapping_of_cell (loc, x, an) = 87 | let default = Ag_ocaml.get_ocaml_default an in 88 | let doc = Ag_doc.get_doc loc an in 89 | let ocaml_t = 90 | `Cell { 91 | Ag_ocaml.ocaml_default = default; 92 | ocaml_fname = ""; 93 | ocaml_mutable = false; 94 | ocaml_fdoc = doc; 95 | } 96 | in 97 | let json_t = `Cell in 98 | { 99 | cel_loc = loc; 100 | cel_value = mapping_of_expr x; 101 | cel_arepr = ocaml_t; 102 | cel_brepr = json_t 103 | } 104 | 105 | 106 | and mapping_of_variant = function 107 | `Variant (loc, (s, an), o) -> 108 | let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in 109 | let doc = Ag_doc.get_doc loc an in 110 | let ocaml_t = 111 | `Variant { 112 | Ag_ocaml.ocaml_cons = ocaml_cons; 113 | ocaml_vdoc = doc; 114 | } 115 | in 116 | let json_t = 117 | if Ag_json.get_json_untyped an 118 | then `Variant { Ag_json.json_cons = None; } 119 | else 120 | let json_cons = Ag_json.get_json_cons s an in 121 | `Variant { Ag_json.json_cons = Some json_cons; } 122 | in 123 | let arg = 124 | match o with 125 | None -> None 126 | | Some x -> Some (mapping_of_expr x) in 127 | { 128 | var_loc = loc; 129 | var_cons = s; 130 | var_arg = arg; 131 | var_arepr = ocaml_t; 132 | var_brepr = json_t 133 | } 134 | 135 | | `Inherit _ -> assert false 136 | 137 | and mapping_of_field ocaml_field_prefix = function 138 | `Field (loc, (s, fk, an), x) -> 139 | let fvalue = mapping_of_expr x in 140 | let ocaml_default, json_unwrapped = 141 | match fk, Ag_ocaml.get_ocaml_default an with 142 | `Required, None -> None, false 143 | | `Optional, None -> Some "None", true 144 | | (`Required | `Optional), Some _ -> 145 | error loc "Superfluous default OCaml value" 146 | | `With_default, Some s -> Some s, false 147 | | `With_default, None -> 148 | (* will try to determine implicit default value later *) 149 | None, false 150 | in 151 | let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in 152 | let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in 153 | let doc = Ag_doc.get_doc loc an in 154 | let json_fname = Ag_json.get_json_fname s an in 155 | let json_tag_field = Ag_json.get_json_tag_field an in 156 | { f_loc = loc; 157 | f_name = s; 158 | f_kind = fk; 159 | f_value = fvalue; 160 | 161 | f_arepr = `Field { 162 | Ag_ocaml.ocaml_default = ocaml_default; 163 | ocaml_fname = ocaml_fname; 164 | ocaml_mutable = ocaml_mutable; 165 | ocaml_fdoc = doc; 166 | }; 167 | 168 | f_brepr = `Field { 169 | Ag_json.json_fname = json_fname; 170 | json_tag_field = json_tag_field; 171 | json_unwrapped = json_unwrapped 172 | }; 173 | } 174 | 175 | | `Inherit _ -> assert false 176 | 177 | 178 | let def_of_atd (loc, (name, param, an), x) = 179 | let ocaml_predef = Ag_ocaml.get_ocaml_predef `Json an in 180 | let doc = Ag_doc.get_doc loc an in 181 | let o = 182 | match as_abstract x with 183 | Some (loc2, an2) -> 184 | (match Ag_ocaml.get_ocaml_module_and_t `Json name an with 185 | None -> None 186 | | Some (types_module, main_module, ext_name) -> 187 | let args = List.map (fun s -> `Tvar (loc, s)) param in 188 | Some (`External 189 | (loc, name, args, 190 | `External (types_module, main_module, ext_name), 191 | `External)) 192 | ) 193 | | None -> Some (mapping_of_expr x) 194 | in 195 | { 196 | def_loc = loc; 197 | def_name = name; 198 | def_param = param; 199 | def_value = o; 200 | def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; 201 | ocaml_ddoc = doc }; 202 | def_brepr = `Def; 203 | } 204 | 205 | let defs_of_atd_module l = 206 | List.map (function `Type def -> def_of_atd def) l 207 | 208 | let defs_of_atd_modules l = 209 | List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module l)) l 210 | -------------------------------------------------------------------------------- /src/ag_oj_run.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Runtime library for JSON 3 | *) 4 | 5 | open Printf 6 | 7 | exception Error of string 8 | 9 | (* 10 | Error messages 11 | *) 12 | let error s = raise (Error s) 13 | 14 | let error_with_line p s = 15 | let s2 = 16 | match p.Yojson.Lexer_state.fname with 17 | Some f -> sprintf "File %s, line %i:\n%s" f p.Yojson.Lexer_state.lnum s 18 | | None -> sprintf "Line %i:\n%s" p.Yojson.Lexer_state.lnum s 19 | in 20 | raise (Error s2) 21 | 22 | 23 | let list_iter f sep x l = 24 | let rec aux f sep x = function 25 | [] -> () 26 | | y :: l -> 27 | sep x; 28 | f x y; 29 | aux f sep x l 30 | in 31 | match l with 32 | [] -> () 33 | | y :: l -> 34 | f x y; 35 | aux f sep x l 36 | 37 | let array_iter f sep x a = 38 | let n = Array.length a in 39 | if n > 0 then ( 40 | f x (Array.unsafe_get a 0); 41 | for i = 1 to n - 1 do 42 | sep x; 43 | f x (Array.unsafe_get a i) 44 | done 45 | ) 46 | 47 | let write_comma ob = 48 | Bi_outbuf.add_char ob ',' 49 | 50 | let write_list write_item ob l = 51 | Bi_outbuf.add_char ob '['; 52 | list_iter write_item write_comma ob l; 53 | Bi_outbuf.add_char ob ']' 54 | 55 | let write_array write_item ob a = 56 | Bi_outbuf.add_char ob '['; 57 | array_iter write_item write_comma ob a; 58 | Bi_outbuf.add_char ob ']' 59 | 60 | let write_assoc_list write_key write_item ob l = 61 | Bi_outbuf.add_char ob '{'; 62 | list_iter ( 63 | fun ob (k, v) -> 64 | write_key ob k; 65 | Bi_outbuf.add_char ob ':'; 66 | write_item ob v 67 | ) write_comma ob l; 68 | Bi_outbuf.add_char ob '}' 69 | 70 | let write_assoc_array write_key write_item ob l = 71 | Bi_outbuf.add_char ob '{'; 72 | array_iter ( 73 | fun ob (k, v) -> 74 | write_key ob k; 75 | Bi_outbuf.add_char ob ':'; 76 | write_item ob v 77 | ) write_comma ob l; 78 | Bi_outbuf.add_char ob '}' 79 | 80 | 81 | let write_option write_item ob = function 82 | None -> Bi_outbuf.add_string ob "<\"None\">" 83 | | Some x -> 84 | Bi_outbuf.add_string ob "<\"Some\":"; 85 | write_item ob x; 86 | Bi_outbuf.add_string ob ">" 87 | 88 | let write_std_option write_item ob = function 89 | None -> Bi_outbuf.add_string ob "\"None\"" 90 | | Some x -> 91 | Bi_outbuf.add_string ob "[\"Some\","; 92 | write_item ob x; 93 | Bi_outbuf.add_string ob "]" 94 | 95 | let write_nullable write_item ob = function 96 | None -> Bi_outbuf.add_string ob "null" 97 | | Some x -> write_item ob x 98 | 99 | let write_int8 ob x = 100 | Yojson.Safe.write_int ob (int_of_char x) 101 | 102 | let write_int32 ob x = 103 | Bi_outbuf.add_string ob (Int32.to_string x) 104 | 105 | let write_int64 ob x = 106 | Bi_outbuf.add_string ob (Int64.to_string x) 107 | 108 | let min_float = float min_int 109 | let max_float = float max_int 110 | 111 | let write_float_as_int ob x = 112 | if x >= min_float && x <= max_float then 113 | Yojson.Safe.write_int ob 114 | (int_of_float (if x < 0. then x -. 0.5 else x +. 0.5)) 115 | else 116 | match classify_float x with 117 | FP_normal 118 | | FP_subnormal 119 | | FP_zero -> Bi_outbuf.add_string ob (Printf.sprintf "%.0f" x) 120 | | FP_infinite -> error "Cannot convert inf or -inf into a JSON int" 121 | | FP_nan -> error "Cannot convert NaN into a JSON int" 122 | 123 | let read_null p lb = 124 | Yojson.Safe.read_space p lb; 125 | Yojson.Safe.read_null p lb 126 | 127 | let read_bool p lb = 128 | Yojson.Safe.read_space p lb; 129 | Yojson.Safe.read_bool p lb 130 | 131 | let read_int p lb = 132 | Yojson.Safe.read_space p lb; 133 | Yojson.Safe.read_int p lb 134 | 135 | let read_int8 p lb = 136 | Yojson.Safe.read_space p lb; 137 | Yojson.Safe.read_int8 p lb 138 | 139 | let read_int32 p lb = 140 | Yojson.Safe.read_space p lb; 141 | Yojson.Safe.read_int32 p lb 142 | 143 | let read_int64 p lb = 144 | Yojson.Safe.read_space p lb; 145 | Yojson.Safe.read_int64 p lb 146 | 147 | let read_number p lb = 148 | Yojson.Safe.read_space p lb; 149 | Yojson.Safe.read_number p lb 150 | 151 | let read_string p lb = 152 | Yojson.Safe.read_space p lb; 153 | Yojson.Safe.read_string p lb 154 | 155 | let read_list read_item p lb = 156 | Yojson.Safe.read_space p lb; 157 | Yojson.Safe.read_list read_item p lb 158 | 159 | let read_array read_item p lb = 160 | Yojson.Safe.read_space p lb; 161 | Yojson.Safe.read_array read_item p lb 162 | 163 | let read_assoc_list_rev read_key read_item p lb = 164 | Yojson.Safe.read_space p lb; 165 | let read acc k p lb = (k, read_item p lb) :: acc in 166 | Yojson.Safe.read_abstract_fields read_key read [] p lb 167 | 168 | let read_assoc_list read_key read_item p lb = 169 | List.rev (read_assoc_list_rev read_key read_item p lb) 170 | 171 | let array_of_rev_list l = 172 | match l with 173 | [] -> [| |] 174 | | x :: tl -> 175 | let len = List.length l in 176 | let a = Array.make len x in 177 | let r = ref tl in 178 | for i = len - 2 downto 0 do 179 | a.(i) <- List.hd !r; 180 | r := List.tl !r 181 | done; 182 | a 183 | 184 | let read_assoc_array read_key read_item p lb = 185 | array_of_rev_list (read_assoc_list_rev read_key read_item p lb) 186 | 187 | let read_until_field_value p lb = 188 | Yojson.Safe.read_space p lb; 189 | Yojson.Safe.read_colon p lb; 190 | Yojson.Safe.read_space p lb 191 | 192 | let missing_tuple_fields p len req_fields = 193 | let missing = 194 | List.fold_right ( 195 | fun i acc -> if i >= len then i :: acc else acc 196 | ) req_fields [] 197 | in 198 | error_with_line p (sprintf "Missing tuple field%s %s" 199 | (if List.length missing > 1 then "s" else "") 200 | (String.concat ", " (List.map string_of_int missing))) 201 | 202 | 203 | let missing_fields p bit_fields field_names = 204 | let acc = ref [] in 205 | for z = Array.length field_names - 1 downto 0 do 206 | let i = z / 31 in 207 | let j = z mod 31 in 208 | if bit_fields.(i) land (1 lsl j) = 0 then 209 | acc := field_names.(z) :: !acc 210 | done; 211 | error_with_line p (sprintf "Missing record field%s %s" 212 | (if List.length !acc > 1 then "s" else "") 213 | (String.concat ", " !acc)) 214 | 215 | let invalid_variant_tag p s = 216 | error_with_line p (sprintf "Unsupported variant %S" s) 217 | 218 | 219 | (* We want an identity function that is not inlined *) 220 | type identity_t = { mutable _identity : 'a. 'a -> 'a } 221 | let identity_ref = { _identity = (fun x -> x) } 222 | let identity x = identity_ref._identity x 223 | 224 | (* 225 | Checking at runtime that our assumptions on unspecified compiler behavior 226 | still hold. 227 | *) 228 | 229 | type t = { 230 | _a : int option; 231 | _b : int; 232 | } 233 | 234 | let create () = 235 | { { _a = None; _b = Array.length Sys.argv } with _a = None } 236 | 237 | let test () = 238 | let r = create () in 239 | let v = Some 17 in 240 | Obj.set_field (Obj.repr r) 0 (Obj.repr v); 241 | let safe_r = identity r in 242 | (* r._a is inlined by ocamlopt and equals None 243 | because the field is supposed to be immutable. *) 244 | assert (safe_r._a = v) 245 | 246 | let () = test () 247 | 248 | (************************************) 249 | -------------------------------------------------------------------------------- /src/ag_ov_emit.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Validators of OCaml data whose types are defined using ATD. 3 | *) 4 | 5 | open Printf 6 | 7 | open Atd_ast 8 | open Ag_error 9 | open Ag_mapping 10 | open Ag_ov_mapping 11 | 12 | let name_of_var s = "_" ^ s 13 | 14 | let make_ocaml_validate_intf ~with_create buf deref defs = 15 | List.iter ( 16 | fun x -> 17 | if with_create && Ag_ox_emit.is_exportable x then ( 18 | let create_record_intf, create_record_impl = 19 | Ag_ox_emit.make_record_creator deref x 20 | in 21 | bprintf buf "%s" create_record_intf; 22 | ); 23 | 24 | let full_name = Ag_ox_emit.get_full_type_name x in 25 | let validator_params = 26 | String.concat "" ( 27 | List.map 28 | (fun s -> 29 | sprintf "\n (Ag_util.Validation.path -> '%s -> \ 30 | Ag_util.Validation.error option) ->" s) 31 | x.def_param 32 | ) 33 | in 34 | let s = x.def_name in 35 | if Ag_ox_emit.is_exportable x then ( 36 | bprintf buf "\ 37 | val validate_%s :%s 38 | Ag_util.Validation.path -> %s -> Ag_util.Validation.error option 39 | (** Validate a value of type {!%s}. *) 40 | 41 | " 42 | s validator_params 43 | full_name 44 | s 45 | ) 46 | ) (flatten defs) 47 | 48 | let nth name i len = 49 | let l = 50 | Array.to_list (Array.init len (fun j -> if i = j then name else "_")) in 51 | String.concat ", " l 52 | 53 | let get_fields a = 54 | let all = 55 | List.map ( 56 | fun x -> 57 | match x.f_arepr with 58 | `Field o -> (x, o.Ag_ocaml.ocaml_fname) 59 | | _ -> assert false 60 | ) 61 | (Array.to_list a) 62 | in 63 | List.filter ( 64 | function 65 | { f_brepr = (None, shallow) }, name -> not shallow 66 | | _ -> assert false 67 | ) all 68 | 69 | let rec forall : Ag_indent.t list -> Ag_indent.t list = function 70 | | [] -> [] 71 | | [x] -> [x] 72 | | x :: l -> 73 | [ 74 | `Line "match"; 75 | `Block [x]; 76 | `Line "with"; 77 | `Block [ 78 | `Line "| Some _ as err -> err"; 79 | `Line "| None ->"; 80 | `Block (forall l); 81 | ] 82 | ] 83 | 84 | let unopt = function None -> assert false | Some x -> x 85 | 86 | let return_true = "fun _ _ -> None" 87 | let return_true_paren = "(fun _ _ -> None)" 88 | 89 | let opt_validator_name = function 90 | None -> return_true_paren 91 | | Some s -> sprintf "( %s )" s 92 | 93 | let opt_validator = function 94 | None -> [ `Line "fun _ _ -> None" ] 95 | | Some s -> [ `Line s ] 96 | 97 | let opt_validator_s = function 98 | None -> "(fun _ _ -> None)" 99 | | Some s -> sprintf "( %s )" s 100 | 101 | 102 | let prepend_validator opt l = 103 | match opt with 104 | None -> l 105 | | Some s -> 106 | [ 107 | `Line (sprintf "match ( %s ) path x with" s); 108 | `Block [ 109 | `Line "| Some _ as err -> err"; 110 | `Line "| None ->"; 111 | `Block l; 112 | ] 113 | ] 114 | 115 | let prepend_validator_s v s2 = 116 | match v with 117 | None -> s2 118 | | Some s1 -> 119 | sprintf "(fun path x -> \ 120 | match ( %s ) path x with \ 121 | | Some _ as err -> err \ 122 | | None -> (%s) path x)" s1 s2 123 | 124 | let prepend_validator_f v l = 125 | match v with 126 | None -> l 127 | | Some s -> 128 | [ 129 | `Line "(fun path x ->"; 130 | `Block [ 131 | `Line (sprintf "(match ( %s ) path x with" s); 132 | `Block [ 133 | `Line "| Some _ as err -> err"; 134 | `Line "| None -> ("; 135 | `Block [ 136 | `Block l; 137 | `Line ") path x"; 138 | ] 139 | ]; 140 | `Line ")"; 141 | ]; 142 | `Line ")"; 143 | ] 144 | 145 | (* 146 | ('a, 'b) t -> 147 | validate_t validate__a validate__b 148 | ('a, foo) t -> 149 | validate_t validate__a validate_foo 150 | ('a, (foo, 'b) bar) t -> 151 | validate_t validate__a (validate_bar validate_foo validate__b) 152 | *) 153 | let rec get_validator_name 154 | ?(paren = false) 155 | ?(name_f = fun s -> "validate_" ^ s) 156 | (x : ov_mapping) : string = 157 | 158 | match x with 159 | `Unit (loc, `Unit, v) 160 | | `Bool (loc, `Bool, v) 161 | | `Int (loc, `Int _, v) 162 | | `Float (loc, `Float, v) 163 | | `String (loc, `String, v) -> 164 | (match v with 165 | (None, true) -> return_true_paren 166 | | (Some s, true) -> s 167 | | (_, false) -> assert false 168 | ) 169 | | `Tvar (loc, s) -> "validate_" ^ name_of_var s 170 | 171 | | `Name (loc, s, args, None, opt) -> 172 | let v1 = 173 | let l = 174 | List.map (get_validator_name ~paren:true) args in 175 | let s = String.concat " " (name_f s :: l) in 176 | if paren && l <> [] then "(" ^ s ^ ")" 177 | else s 178 | in 179 | (match opt with 180 | None -> v1 181 | | Some (o, false) -> prepend_validator_s o v1 182 | | Some (o, true) -> opt_validator_s o 183 | ) 184 | 185 | | `External (loc, s, args, 186 | `External (types_module, main_module, ext_name), 187 | v) -> 188 | (match v with 189 | (o, false) -> 190 | prepend_validator_s o ( 191 | let f = main_module ^ "." ^ name_f ext_name in 192 | let l = List.map (get_validator_name ~paren:true) args in 193 | let s = String.concat " " (f :: l) in 194 | if paren && l <> [] then "(" ^ s ^ ")" 195 | else s 196 | ) 197 | | (_, true) -> assert false 198 | ) 199 | 200 | | _ -> assert false 201 | 202 | 203 | let get_left_validator_name name param = 204 | let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in 205 | get_validator_name (`Name (dummy_loc, name, args, None, None)) 206 | 207 | let rec make_validator (x : ov_mapping) : Ag_indent.t list = 208 | match x with 209 | `Unit _ 210 | | `Bool _ 211 | | `Int _ 212 | | `Float _ 213 | | `String _ 214 | | `Name _ 215 | | `External _ 216 | | `Tvar _ -> [ `Line (get_validator_name x) ] 217 | 218 | | `Sum (loc, a, `Sum x, (v, shallow)) -> 219 | if shallow then 220 | opt_validator v 221 | else 222 | let tick = 223 | match x with 224 | `Classic -> "" 225 | | `Poly -> "`" 226 | in 227 | let body : Ag_indent.t list = 228 | [ 229 | `Line "match x with"; 230 | `Block ( 231 | Array.to_list ( 232 | Array.map 233 | (fun x -> `Inline (make_variant_validator tick x)) 234 | a 235 | ) 236 | ) 237 | ] 238 | in 239 | [ 240 | `Annot ("fun", `Line "fun path x ->"); 241 | `Block (prepend_validator v body); 242 | ] 243 | 244 | | `Record (loc, a, `Record o, (v, shallow)) -> 245 | if shallow then 246 | opt_validator v 247 | else 248 | [ 249 | `Annot ("fun", `Line "fun path x ->"); 250 | `Block (prepend_validator v (make_record_validator a o)); 251 | ] 252 | 253 | | `Tuple (loc, a, `Tuple, (v, shallow)) -> 254 | if shallow then 255 | opt_validator v 256 | else 257 | let len = Array.length a in 258 | let l = Array.to_list (Array.mapi (fun i x -> (i, x)) a) in 259 | let l = List.filter (fun (i, x) -> not (snd x.cel_brepr)) l in 260 | let l = 261 | List.map ( 262 | fun (i, x) -> 263 | `Inline [ 264 | `Line (sprintf "(let %s = x in" (nth "x" i len)); 265 | `Line "("; 266 | `Block (make_validator x.cel_value); 267 | `Line (sprintf ") (`Index %i :: path) x" i); 268 | `Line ")" 269 | ] 270 | ) l 271 | in 272 | let l = forall l 273 | in 274 | [ 275 | `Annot ("fun", `Line "fun path x ->"); 276 | `Block (prepend_validator v l); 277 | ] 278 | 279 | | `List (loc, x, `List o, (v, shallow)) -> 280 | if shallow then 281 | opt_validator v 282 | else 283 | let validate = 284 | match o with 285 | `List -> "Ag_ov_run.validate_list (" 286 | | `Array -> "Ag_ov_run.validate_array (" 287 | in 288 | prepend_validator_f v [ 289 | `Line validate; 290 | `Block (make_validator x); 291 | `Line ")"; 292 | ] 293 | 294 | | `Option (loc, x, `Option, (v, shallow)) 295 | | `Nullable (loc, x, `Nullable, (v, shallow)) -> 296 | if shallow then 297 | opt_validator v 298 | else 299 | prepend_validator_f v [ 300 | `Line "Ag_ov_run.validate_option ("; 301 | `Block (make_validator x); 302 | `Line ")"; 303 | ] 304 | 305 | | `Wrap (loc, x, `Wrap o, (v, shallow)) -> 306 | if shallow then 307 | opt_validator v 308 | else 309 | prepend_validator_f v (make_validator x) 310 | 311 | | _ -> assert false 312 | 313 | 314 | 315 | and make_variant_validator tick x : 316 | Ag_indent.t list = 317 | let o = 318 | match x.var_arepr, x.var_brepr with 319 | `Variant o, (None, _) -> o 320 | | _ -> assert false 321 | in 322 | let ocaml_cons = o.Ag_ocaml.ocaml_cons in 323 | match x.var_arg with 324 | None -> 325 | [ 326 | `Line (sprintf "| %s%s -> None" tick ocaml_cons) 327 | ] 328 | | Some v -> 329 | [ 330 | `Line (sprintf "| %s%s x ->" tick ocaml_cons); 331 | `Block [ 332 | `Line "("; 333 | `Block (make_validator v); 334 | `Line ") path x" 335 | ] 336 | ] 337 | 338 | and make_record_validator a record_kind = 339 | let dot = 340 | match record_kind with 341 | `Record -> "." 342 | | `Object -> "#" 343 | in 344 | let fields = get_fields a in 345 | assert (fields <> []); 346 | let validate_fields : Ag_indent.t list = 347 | List.map ( 348 | fun (x, ocaml_fname) -> 349 | `Inline [ 350 | `Line "("; 351 | `Block (make_validator x.Ag_mapping.f_value); 352 | `Line (sprintf 353 | ") (`Field %S :: path) x%s%s" ocaml_fname dot ocaml_fname); 354 | ] 355 | ) fields 356 | in 357 | forall validate_fields 358 | 359 | let make_ocaml_validator ~original_types is_rec let1 let2 def = 360 | let x = match def.def_value with None -> assert false | Some x -> x in 361 | let name = def.def_name in 362 | let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in 363 | let param = def.def_param in 364 | let validate = get_left_validator_name name param in 365 | let validator_expr = make_validator x in 366 | let eta_expand = is_rec && not (Ag_ox_emit.is_function validator_expr) in 367 | let needs_annot = Ag_ox_emit.needs_type_annot x in 368 | let extra_param, extra_args, type_annot = 369 | match eta_expand, needs_annot with 370 | | true, false -> " path x", " path x", None 371 | | true, true -> sprintf " path (x : %s)" type_constraint, " path x", None 372 | | false, false -> "", "", None 373 | | false, true -> "", "", Some (sprintf "_ -> %s -> _" type_constraint) 374 | in 375 | [ 376 | `Line (sprintf "%s %s = (" 377 | let1 378 | (Ag_ox_emit.opt_annot_def type_annot (validate ^ extra_param))); 379 | `Block (List.map Ag_indent.strip validator_expr); 380 | `Line (sprintf ")%s" extra_args); 381 | ] 382 | 383 | 384 | 385 | let map f = function 386 | [] -> [] 387 | | x :: l -> 388 | let y = f true x in 389 | y :: List.map (f false) l 390 | 391 | let get_let ~is_rec ~is_first = 392 | if is_first then 393 | if is_rec then "let rec", "and" 394 | else "let", "let" 395 | else "and", "and" 396 | 397 | let make_ocaml_validate_impl ~with_create ~original_types buf deref defs = 398 | let ll = 399 | List.map ( 400 | fun (is_rec, l) -> 401 | let l = List.filter (fun x -> x.def_value <> None) l in 402 | let validators = 403 | map ( 404 | fun is_first def -> 405 | let let1, let2 = get_let ~is_rec ~is_first in 406 | make_ocaml_validator ~original_types is_rec let1 let2 def 407 | ) l 408 | in 409 | List.flatten validators 410 | ) defs 411 | in 412 | Atd_indent.to_buffer buf (List.flatten ll); 413 | 414 | if with_create then 415 | List.iter ( 416 | fun (is_rec, l) -> 417 | let l = List.filter Ag_ox_emit.is_exportable l in 418 | List.iter ( 419 | fun x -> 420 | let intf, impl = Ag_ox_emit.make_record_creator deref x in 421 | Buffer.add_string buf impl 422 | ) l 423 | ) defs 424 | 425 | 426 | (* 427 | Glue 428 | *) 429 | 430 | let translate_mapping (l : (bool * Atd_ast.module_body) list) = 431 | Ag_ov_mapping.defs_of_atd_modules l 432 | 433 | let write_opens buf l = 434 | List.iter (fun s -> bprintf buf "open %s\n" s) l; 435 | bprintf buf "\n" 436 | 437 | let make_mli 438 | ~header ~opens ~with_typedefs ~with_create ~with_fundefs 439 | ocaml_typedefs deref defs = 440 | let buf = Buffer.create 1000 in 441 | bprintf buf "%s\n" header; 442 | write_opens buf opens; 443 | if with_typedefs then 444 | bprintf buf "%s\n" ocaml_typedefs; 445 | if with_typedefs && with_fundefs then 446 | bprintf buf "\n"; 447 | if with_fundefs then 448 | make_ocaml_validate_intf ~with_create buf deref defs; 449 | Buffer.contents buf 450 | 451 | let make_ml 452 | ~header ~opens ~with_typedefs ~with_create ~with_fundefs 453 | ~original_types ocaml_typedefs deref defs = 454 | let buf = Buffer.create 1000 in 455 | bprintf buf "%s\n" header; 456 | write_opens buf opens; 457 | if with_typedefs then 458 | bprintf buf "%s\n" ocaml_typedefs; 459 | if with_typedefs && with_fundefs then 460 | bprintf buf "\n"; 461 | if with_fundefs then 462 | make_ocaml_validate_impl ~with_create ~original_types buf deref defs; 463 | Buffer.contents buf 464 | 465 | let make_ocaml_files 466 | ~opens 467 | ~with_typedefs 468 | ~with_create 469 | ~with_fundefs 470 | ~all_rec 471 | ~pos_fname 472 | ~pos_lnum 473 | ~type_aliases 474 | ~force_defaults 475 | ~name_overlap 476 | ~ocaml_version 477 | ~pp_convs 478 | atd_file out = 479 | let ((head, m0), _) = 480 | match atd_file with 481 | Some file -> 482 | Atd_util.load_file 483 | ~expand:false ~inherit_fields:true ~inherit_variants:true 484 | ?pos_fname ?pos_lnum 485 | file 486 | | None -> 487 | Atd_util.read_channel 488 | ~expand:false ~inherit_fields:true ~inherit_variants:true 489 | ?pos_fname ?pos_lnum 490 | stdin 491 | in 492 | let tsort = 493 | if all_rec then 494 | function m -> [ (true, m) ] 495 | else 496 | Atd_util.tsort 497 | in 498 | let m1 = tsort m0 499 | in 500 | let defs1 = translate_mapping m1 in 501 | if not name_overlap then Ag_ox_emit.check defs1; 502 | let (m1', original_types) = 503 | Atd_expand.expand_module_body ~keep_poly:true m0 504 | in 505 | let m2 = tsort m1' in 506 | (* m0 = original type definitions 507 | m1 = original type definitions after dependency analysis 508 | m2 = monomorphic type definitions after dependency analysis *) 509 | let ocaml_typedefs = 510 | Ag_ocaml.ocaml_of_atd ~pp_convs ~target:`Validate ~type_aliases (head, m1) in 511 | let defs = translate_mapping m2 in 512 | let header = 513 | let src = 514 | match atd_file with 515 | None -> "stdin" 516 | | Some path -> sprintf "%S" (Filename.basename path) 517 | in 518 | sprintf "(* Auto-generated from %s *)\n" src 519 | in 520 | let mli = 521 | make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs 522 | ocaml_typedefs (Ag_mapping.make_deref defs1) defs1 523 | in 524 | let ml = 525 | make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs 526 | ~original_types ocaml_typedefs (Ag_mapping.make_deref defs) defs 527 | in 528 | Ag_ox_emit.write_ocaml out mli ml 529 | -------------------------------------------------------------------------------- /src/ag_ov_mapping.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Atd_ast 3 | open Ag_error 4 | open Ag_mapping 5 | 6 | type o = Ag_ocaml.atd_ocaml_repr 7 | type v = Ag_validate.validate_repr 8 | 9 | type ov_mapping = 10 | (Ag_ocaml.atd_ocaml_repr, Ag_validate.validate_repr) Ag_mapping.mapping 11 | 12 | type ob_def = 13 | (Ag_ocaml.atd_ocaml_repr, Ag_validate.validate_repr) Ag_mapping.def 14 | 15 | (* 16 | Determine whether a type expression does not need validation. 17 | 18 | 1. Flatten. 19 | For each type expression of interest, produce the list 20 | of all type expressions on which it depends. 21 | 22 | 2. Read annotations. 23 | If any of the type expressions has a validator annotation or if 24 | on the type expressions is abstract, then the result is false. 25 | *) 26 | 27 | let ploc x = 28 | eprintf "%s\n" (string_of_loc (loc_of_type_expr x)) 29 | 30 | let print s = 31 | eprintf "%s\n%!" s 32 | 33 | let get_def defs name : type_expr option = 34 | try Some (Hashtbl.find defs name) 35 | with Not_found -> None 36 | 37 | let noval x = 38 | let an = Atd_ast.annot_of_type_expr x in 39 | Ag_validate.get_validator an = None 40 | 41 | module H = Hashtbl.Make ( 42 | struct 43 | type t = type_expr 44 | let equal = ( == ) 45 | let hash = Hashtbl.hash 46 | end 47 | ) 48 | 49 | let for_all_children f x0 = 50 | let is_root = ref true in 51 | try 52 | Atd_ast.fold ( 53 | fun x () -> 54 | if !is_root then ( 55 | is_root := false; 56 | assert (x == x0); 57 | ) 58 | else 59 | if not (f x) then 60 | raise Exit 61 | ) x0 (); 62 | true 63 | with Exit -> 64 | false 65 | 66 | (* 67 | Return if an expression is shallow, i.e. it does not require to call 68 | a validation function other than the one possibly given 69 | by an annotation on this node. 70 | 71 | Shallow: 72 | int 73 | int 74 | { x : int } 75 | t (* where t is defined as: type t = int *) 76 | 77 | Not shallow: 78 | t (* where t is defined as: type t = int *) 79 | { x : int } 80 | 'a t 81 | t (* where t is defined as: type t = abstract *) 82 | *) 83 | let rec scan_expr 84 | (defs : (string, type_expr) Hashtbl.t) 85 | (visited : unit H.t) 86 | (results : bool H.t) 87 | (x : type_expr) : bool = 88 | 89 | if not (H.mem visited x) then ( 90 | H.add visited x (); 91 | try H.find results x 92 | with Not_found -> 93 | name_is_shallow defs visited results x 94 | && for_all_children ( 95 | fun x -> 96 | noval x 97 | && scan_expr defs visited results x 98 | ) x 99 | ) 100 | else 101 | (* neutral for the && operator *) 102 | true 103 | 104 | and name_is_shallow defs visited results x = 105 | match x with 106 | `Name (loc, (loc2, name, _), _) -> 107 | (match get_def defs name with 108 | None -> 109 | (match name with 110 | "unit" 111 | | "bool" 112 | | "int" 113 | | "float" 114 | | "string" -> true 115 | | _ -> false 116 | ) 117 | | Some x -> noval x && scan_expr defs visited results x 118 | ) 119 | 120 | | `Tvar (loc, _) -> false 121 | | _ -> (* already verified in the call to scan_expr above *) true 122 | 123 | 124 | let iter f x = 125 | Atd_ast.fold (fun x () -> f x) x () 126 | 127 | let scan_top_expr 128 | (defs : (string, type_expr) Hashtbl.t) 129 | (results : bool H.t) 130 | (x : type_expr) : unit = 131 | 132 | (* Force-scan all sub-expressions *) 133 | iter ( 134 | fun x -> 135 | if not (H.mem results x) then ( 136 | let b = scan_expr defs (H.create 10) results x in 137 | (try 138 | let b0 = H.find results x in 139 | assert (b0 = b); 140 | with Not_found -> ()); 141 | H.replace results x b 142 | ) 143 | ) x 144 | 145 | let make_is_shallow defs = 146 | let results = H.create 100 in 147 | Hashtbl.iter ( 148 | fun name x -> scan_top_expr defs results x 149 | ) defs; 150 | fun x -> 151 | try 152 | H.find results x 153 | with Not_found -> assert false 154 | 155 | (* 156 | Translation of the types into the ocaml/validate mapping. 157 | *) 158 | 159 | let rec mapping_of_expr 160 | (is_shallow : type_expr -> bool) 161 | (x0 : type_expr) : ov_mapping = 162 | 163 | let v an = Ag_validate.get_validator an in 164 | let v2 an x = (Ag_validate.get_validator an, is_shallow x) in 165 | match x0 with 166 | `Sum (loc, l, an) -> 167 | let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in 168 | `Sum (loc, Array.of_list (List.map (mapping_of_variant is_shallow) l), 169 | ocaml_t, v2 an x0) 170 | 171 | | `Record (loc, l, an) -> 172 | let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in 173 | let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in 174 | `Record (loc, 175 | Array.of_list 176 | (List.map 177 | (mapping_of_field is_shallow ocaml_field_prefix) l), 178 | ocaml_t, v2 an x0) 179 | 180 | | `Tuple (loc, l, an) -> 181 | let ocaml_t = `Tuple in 182 | `Tuple (loc, Array.of_list (List.map (mapping_of_cell is_shallow) l), 183 | ocaml_t, v2 an x0) 184 | 185 | | `List (loc, x, an) -> 186 | let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in 187 | `List (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) 188 | 189 | | `Option (loc, x, an) -> 190 | let ocaml_t = `Option in 191 | `Option (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) 192 | 193 | | `Nullable (loc, x, an) -> 194 | let ocaml_t = `Nullable in 195 | `Nullable (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) 196 | 197 | | `Shared (loc, x, an) -> 198 | failwith "Sharing is not supported" 199 | 200 | | `Wrap (loc, x, an) -> 201 | let w = Ag_ocaml.get_ocaml_wrap loc an in 202 | let ocaml_t = `Wrap w in 203 | let validator = 204 | match w with 205 | None -> v2 an x0 206 | | Some _ -> v an, true 207 | in 208 | `Wrap (loc, mapping_of_expr is_shallow x, ocaml_t, validator) 209 | 210 | | `Name (loc, (loc2, s, l), an) -> 211 | (match s with 212 | "unit" -> 213 | `Unit (loc, `Unit, (v an, true)) 214 | | "bool" -> 215 | `Bool (loc, `Bool, (v an, true)) 216 | | "int" -> 217 | let o = Ag_ocaml.get_ocaml_int an in 218 | `Int (loc, `Int o, (v an, true)) 219 | | "float" -> 220 | `Float (loc, `Float, (v an, true)) 221 | | "string" -> 222 | `String (loc, `String, (v an, true)) 223 | | s -> 224 | let validator = 225 | match v2 an x0 with 226 | None, true -> None 227 | | x -> Some x 228 | in 229 | `Name (loc, s, List.map (mapping_of_expr is_shallow) l, 230 | None, validator) 231 | ) 232 | | `Tvar (loc, s) -> 233 | `Tvar (loc, s) 234 | 235 | and mapping_of_cell is_shallow (loc, x, an) = 236 | let default = Ag_ocaml.get_ocaml_default an in 237 | let doc = Ag_doc.get_doc loc an in 238 | let ocaml_t = 239 | `Cell { 240 | Ag_ocaml.ocaml_default = default; 241 | ocaml_fname = ""; 242 | ocaml_mutable = false; 243 | ocaml_fdoc = doc; 244 | } 245 | in 246 | { 247 | cel_loc = loc; 248 | cel_value = mapping_of_expr is_shallow x; 249 | cel_arepr = ocaml_t; 250 | cel_brepr = (None, noval x && is_shallow x) 251 | } 252 | 253 | 254 | and mapping_of_variant is_shallow = function 255 | `Variant (loc, (s, an), o) -> 256 | let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in 257 | let doc = Ag_doc.get_doc loc an in 258 | let ocaml_t = 259 | `Variant { 260 | Ag_ocaml.ocaml_cons = ocaml_cons; 261 | ocaml_vdoc = doc; 262 | } 263 | in 264 | let arg, validate_t = 265 | match o with 266 | None -> 267 | None, (None, true) 268 | | Some x -> 269 | (Some (mapping_of_expr is_shallow x), 270 | (None, noval x && is_shallow x)) 271 | in 272 | { 273 | var_loc = loc; 274 | var_cons = s; 275 | var_arg = arg; 276 | var_arepr = ocaml_t; 277 | var_brepr = validate_t; 278 | } 279 | 280 | | `Inherit _ -> assert false 281 | 282 | and mapping_of_field is_shallow ocaml_field_prefix = function 283 | `Field (loc, (s, fk, an), x) -> 284 | let fvalue = mapping_of_expr is_shallow x in 285 | let ocaml_default = 286 | match fk, Ag_ocaml.get_ocaml_default an with 287 | `Required, None -> None 288 | | `Optional, None -> Some "None" 289 | | (`Required | `Optional), Some _ -> 290 | error loc "Superfluous default OCaml value" 291 | | `With_default, Some s -> Some s 292 | | `With_default, None -> 293 | (* will try to determine implicit default value later *) 294 | None 295 | in 296 | let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in 297 | let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in 298 | let doc = Ag_doc.get_doc loc an in 299 | { f_loc = loc; 300 | f_name = s; 301 | f_kind = fk; 302 | f_value = fvalue; 303 | 304 | f_arepr = `Field { 305 | Ag_ocaml.ocaml_default = ocaml_default; 306 | ocaml_fname = ocaml_fname; 307 | ocaml_mutable = ocaml_mutable; 308 | ocaml_fdoc = doc; 309 | }; 310 | 311 | f_brepr = (None, noval x && is_shallow x); 312 | } 313 | 314 | | `Inherit _ -> assert false 315 | 316 | 317 | let def_of_atd is_shallow (loc, (name, param, an), x) = 318 | let ocaml_predef = Ag_ocaml.get_ocaml_predef `Validate an in 319 | let doc = Ag_doc.get_doc loc an in 320 | let o = 321 | match as_abstract x with 322 | Some (loc2, an2) -> 323 | (match Ag_ocaml.get_ocaml_module_and_t `Validate name an with 324 | None -> None 325 | | Some (types_module, main_module, ext_name) -> 326 | let args = List.map (fun s -> `Tvar (loc, s)) param in 327 | Some (`External 328 | (loc, name, args, 329 | `External (types_module, main_module, ext_name), 330 | (Ag_validate.get_validator an2, false)) 331 | ) 332 | ) 333 | | None -> Some (mapping_of_expr is_shallow x) 334 | in 335 | { 336 | def_loc = loc; 337 | def_name = name; 338 | def_param = param; 339 | def_value = o; 340 | def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; 341 | ocaml_ddoc = doc; }; 342 | def_brepr = (None, false); 343 | } 344 | 345 | let fill_def_tbl defs l = 346 | List.iter ( 347 | function `Type (loc, (name, param, an), x) -> Hashtbl.add defs name x 348 | ) l 349 | 350 | let init_def_tbl () = 351 | Hashtbl.create 100 352 | 353 | let make_def_tbl l = 354 | let defs = init_def_tbl () in 355 | fill_def_tbl defs l; 356 | defs 357 | 358 | let make_def_tbl2 l = 359 | let defs = init_def_tbl () in 360 | List.iter (fun (is_rec, l) -> fill_def_tbl defs l) l; 361 | defs 362 | 363 | let defs_of_atd_module_gen is_shallow l = 364 | List.map (function `Type def -> def_of_atd is_shallow def) l 365 | 366 | let defs_of_atd_module l = 367 | let defs = make_def_tbl l in 368 | let is_shallow = make_is_shallow defs in 369 | defs_of_atd_module_gen is_shallow l 370 | 371 | let defs_of_atd_modules l = 372 | let defs = make_def_tbl2 l in 373 | let is_shallow = make_is_shallow defs in 374 | List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module_gen is_shallow l)) l 375 | -------------------------------------------------------------------------------- /src/ag_ov_run.ml: -------------------------------------------------------------------------------- 1 | let validate_list f path l = 2 | let rec loop f path i = function 3 | | [] -> None 4 | | x :: l -> 5 | let subpath = `Index i :: path in 6 | match f subpath x with 7 | None -> loop f path (i+1) l 8 | | err -> err 9 | in 10 | loop f path 0 l 11 | 12 | let validate_array f path a = 13 | let rec loop f path a len i = 14 | if i >= len then None 15 | else 16 | match f (`Index i :: path) a.(i) with 17 | None -> loop f path a len (i+1) 18 | | err -> err 19 | in 20 | loop f path a (Array.length a) 0 21 | 22 | let validate_option f path = function 23 | None -> None 24 | | Some x -> f path x 25 | -------------------------------------------------------------------------------- /src/ag_ox_emit.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Tools shared between OCaml code generators. 3 | (ox means OCaml-X) 4 | *) 5 | 6 | open Printf 7 | 8 | open Ag_error 9 | open Ag_mapping 10 | 11 | type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping 12 | type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def 13 | type 'a grouped_defs = (bool * 'a def list) list 14 | 15 | type name = (loc * loc * string) 16 | (* location of the containing record or variant, 17 | location of the field definition, 18 | field/constructor name *) 19 | 20 | type names = { 21 | field_names : name list list; 22 | poly_variant_names : name list list; 23 | classic_variant_names : name list list; 24 | } 25 | 26 | let rec extract_names_from_expr ?(is_root = false) root_loc acc (x : 'a expr) = 27 | match x with 28 | `Unit _ 29 | | `Bool _ 30 | | `Int _ 31 | | `Float _ 32 | | `String _ -> acc 33 | | `Sum (loc, va, o, _) -> 34 | let l, (fn, pvn, cvn) = 35 | Array.fold_left (extract_names_from_variant root_loc) ([], acc) va 36 | in 37 | (match o with 38 | `Sum x -> 39 | (match x with 40 | `Poly -> (fn, l :: pvn, cvn) 41 | | `Classic -> 42 | if is_root then (fn, pvn, l :: cvn) 43 | else 44 | error loc 45 | "Anonymous classic variant types are not allowed \ 46 | by OCaml." 47 | ) 48 | | _ -> assert false 49 | ) 50 | 51 | | `Record (loc, fa, _, _) -> 52 | if is_root then 53 | let l, (fn, pvn, cvn) = 54 | Array.fold_left (extract_names_from_field root_loc) ([], acc) fa 55 | in 56 | (l :: fn, pvn, cvn) 57 | else 58 | error loc "Anonymous record types are not allowed by OCaml." 59 | 60 | | `Tuple (loc, ca, _, _) -> 61 | Array.fold_left (extract_names_from_cell root_loc) acc ca 62 | 63 | | `List (loc, x, _, _) 64 | | `Option (loc, x, _, _) 65 | | `Nullable (loc, x, _, _) 66 | | `Wrap (loc, x, _, _) -> 67 | extract_names_from_expr root_loc acc x 68 | 69 | | `Name (loc, _, l, _, _) -> 70 | List.fold_left (extract_names_from_expr root_loc) acc l 71 | 72 | | `External (loc, _, l, _, _) -> 73 | List.fold_left (extract_names_from_expr root_loc) acc l 74 | 75 | | `Tvar _ -> acc 76 | 77 | and extract_names_from_variant root_loc (l, acc) x = 78 | let l = 79 | match x.var_arepr with 80 | `Variant v -> (root_loc, x.var_loc, v.Ag_ocaml.ocaml_cons) :: l 81 | | _ -> assert false 82 | in 83 | match x.var_arg with 84 | None -> (l, acc) 85 | | Some x -> 86 | (l, extract_names_from_expr root_loc acc x) 87 | 88 | and extract_names_from_field root_loc (l, acc) x = 89 | let l = 90 | match x.f_arepr with 91 | `Field f -> (root_loc, x.f_loc, f.Ag_ocaml.ocaml_fname) :: l 92 | | _ -> assert false 93 | in 94 | (l, extract_names_from_expr root_loc acc x.f_value) 95 | 96 | and extract_names_from_cell root_loc acc x = 97 | extract_names_from_expr root_loc acc x.cel_value 98 | 99 | 100 | let extract_ocaml_names_from_defs l = 101 | let fn, pvn, cvn = 102 | List.fold_left ( 103 | fun acc def -> 104 | match def.def_value with 105 | None -> acc 106 | | Some x -> 107 | let root_loc = loc_of_mapping x in 108 | extract_names_from_expr ~is_root:true root_loc acc x 109 | ) ([], [], []) l 110 | in 111 | { 112 | field_names = List.rev fn; 113 | poly_variant_names = List.rev pvn; 114 | classic_variant_names = List.rev cvn; 115 | } 116 | 117 | let flatten_defs (grouped_defs : 'a grouped_defs) : 'a def list = 118 | List.flatten (List.map snd grouped_defs) 119 | 120 | 121 | let check_duplicate_names container_kind field_kind l = 122 | let tbl = Hashtbl.create 200 in 123 | List.iter ( 124 | fun (root_loc, loc, s) -> 125 | try 126 | let orig_loc = Hashtbl.find tbl s in 127 | let msg1 = 128 | sprintf "\ 129 | %s contains a %s that is already defined elsewhere 130 | and cannot be reused." 131 | (String.capitalize container_kind) field_kind 132 | in 133 | let msg2 = sprintf "First definition of %s %s." field_kind s in 134 | let msg3 = sprintf "\ 135 | Impossible second definition of %s %s. 136 | 137 | Use a different name, possibly by placing 138 | after the field name or variant name in the ATD type definition. 139 | can also be used after a whole record." 140 | field_kind s 141 | in 142 | if loc <> orig_loc then 143 | error3 144 | root_loc msg1 145 | orig_loc msg2 146 | loc msg3 147 | else 148 | error2 149 | root_loc msg1 150 | orig_loc msg2 151 | 152 | with Not_found -> 153 | Hashtbl.add tbl s loc 154 | ) l 155 | 156 | let check_names x = 157 | check_duplicate_names "record type" "field name" 158 | (List.flatten x.field_names); 159 | check_duplicate_names "variant type" "constructor name" 160 | (List.flatten x.classic_variant_names) 161 | 162 | 163 | let check grouped_defs = 164 | let x = extract_ocaml_names_from_defs (flatten_defs grouped_defs) in 165 | check_names x 166 | 167 | 168 | let get_full_type_name x = 169 | let s = x.def_name in 170 | match x.def_param with 171 | [] -> s 172 | | [x] -> sprintf "'%s %s" x s 173 | | l -> 174 | let l = List.map (fun s -> "'" ^ s) l in 175 | sprintf "(%s) %s" (String.concat ", " l) s 176 | 177 | let anon_param_type_name s n_param = 178 | match n_param with 179 | | 0 -> s 180 | | 1 -> "_ " ^ s 181 | | n -> 182 | let underscores = Array.make n "_" in 183 | let params = String.concat ", " (Array.to_list underscores) in 184 | "(" ^ params ^ ") " ^ s 185 | 186 | (* Get a type expression that uses the original user-given name (e.g. not _1) *) 187 | let get_type_constraint ~original_types def = 188 | try 189 | let (poly_name, n_params) = Hashtbl.find original_types def.def_name in 190 | anon_param_type_name poly_name n_params 191 | with Not_found -> 192 | get_full_type_name def 193 | 194 | 195 | (* Classic variants and records need type annotations in order to allow 196 | constructor/field name disambiguation *) 197 | let needs_type_annot (x : _ expr) = 198 | match x with 199 | | `Record (_, _, `Record `Record, _) 200 | | `Sum (_, _, `Sum `Classic, _) -> true 201 | | _ -> false 202 | 203 | let insert_annot type_annot = 204 | match type_annot with 205 | | None -> "" 206 | | Some t -> sprintf " : %s" t 207 | 208 | (* Add an optional type annotation on an OCaml expression or pattern *) 209 | let opt_annot type_annot expr = 210 | match type_annot with 211 | | None -> expr 212 | | Some t -> sprintf "(%s : %s)" expr t 213 | 214 | (* Add an optional type annotation after all function parameters 215 | in a let binding (last thing before the equal sign) *) 216 | let opt_annot_def type_annot fun_param = 217 | match type_annot with 218 | | None -> fun_param 219 | | Some t -> sprintf "%s : %s" fun_param t 220 | 221 | 222 | let write_file file s = 223 | let oc = open_out_bin file in 224 | output_string oc s; 225 | close_out oc 226 | 227 | let write_ocaml out mli ml = 228 | match out with 229 | `Stdout -> 230 | printf "\ 231 | struct 232 | %s 233 | end : 234 | sig 235 | %s 236 | end 237 | " 238 | ml mli; 239 | flush stdout 240 | 241 | | `Files prefix -> 242 | write_file (prefix ^ ".mli") mli; 243 | write_file (prefix ^ ".ml") ml 244 | 245 | let is_exportable def = 246 | let s = def.def_name in 247 | s <> "" && s.[0] <> '_' 248 | && def.def_value <> None 249 | 250 | let make_record_creator deref x = 251 | match x.def_value with 252 | Some (`Record (loc, a, `Record `Record, _)) -> 253 | let s = x.def_name in 254 | let full_name = get_full_type_name x in 255 | let l = 256 | Array.to_list 257 | (Array.map (Ag_ocaml.map_record_creator_field deref) a) in 258 | let intf_params = List.map (fun (x, _, _) -> x) l in 259 | let intf = 260 | sprintf "\ 261 | val create_%s :%s 262 | unit -> %s 263 | (** Create a record of type {!%s}. *) 264 | 265 | " 266 | s (String.concat "" intf_params) 267 | full_name 268 | s 269 | in 270 | let impl_params = List.map (fun (_, x, _) -> x) l in 271 | let impl_fields = List.map (fun (_, _, x) -> x) l in 272 | let impl = 273 | sprintf "\ 274 | let create_%s %s 275 | () : %s = 276 | {%s 277 | } 278 | " 279 | s (String.concat "" impl_params) full_name 280 | (String.concat "" impl_fields) 281 | in 282 | intf, impl 283 | 284 | | _ -> "", "" 285 | 286 | let rec is_function (l : Ag_indent.t list) = 287 | match l with 288 | [] -> false 289 | | x :: _ -> 290 | match x with 291 | `Line _ -> false 292 | | `Block l -> is_function l 293 | | `Inline l -> is_function l 294 | | `Annot ("fun", _) -> true 295 | | `Annot (_, x) -> is_function [x] 296 | -------------------------------------------------------------------------------- /src/ag_ox_emit.mli: -------------------------------------------------------------------------------- 1 | type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping 2 | type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def 3 | type 'a grouped_defs = (bool * 'a def list) list 4 | 5 | val get_full_type_name : (_, _) Ag_mapping.def -> string 6 | 7 | val is_exportable : (_, _) Ag_mapping.def -> bool 8 | 9 | val make_record_creator 10 | : ((Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping 11 | -> (Ag_ocaml.atd_ocaml_repr, 'b) Ag_mapping.mapping) 12 | -> (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def 13 | -> string * string 14 | 15 | val opt_annot : string option -> string -> string 16 | 17 | val opt_annot_def : string option -> string -> string 18 | 19 | val insert_annot : string option -> string 20 | 21 | val get_type_constraint 22 | : original_types:(string, string * int) Hashtbl.t 23 | -> ('a, 'b) Ag_mapping.def 24 | -> string 25 | 26 | val is_function : Ag_indent.t list -> bool 27 | 28 | val needs_type_annot : _ expr -> bool 29 | 30 | val check : _ grouped_defs -> unit 31 | 32 | val write_ocaml : [< `Files of string | `Stdout ] -> string -> string -> unit 33 | -------------------------------------------------------------------------------- /src/ag_string_match.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | type position = [ `Length | `Position of int | `End ] 5 | type value = [ `Int of int | `Char of char ] 6 | 7 | type 'a tree = 8 | [ `Node of (position * (value * 'a tree) list) 9 | | `Branch of ((position * value) list * 'a tree) 10 | | `Leaf of 'a ] 11 | 12 | let group_by f l = 13 | let tbl = Hashtbl.create 20 in 14 | List.iter ( 15 | fun x -> 16 | let k = f x in 17 | let r = 18 | try Hashtbl.find tbl k 19 | with Not_found -> 20 | let r = ref [] in 21 | Hashtbl.add tbl k r; 22 | r 23 | in 24 | r := x :: !r 25 | ) l; 26 | let l = Hashtbl.fold (fun k r l -> (k, List.rev !r) :: l) tbl [] in 27 | List.sort (fun (k1, _) (k2, _) -> compare k1 k2) l 28 | 29 | 30 | let rec finish s pos = 31 | match pos with 32 | `End -> [] 33 | | `Length -> 34 | (`Length, `Int (String.length s)) :: finish s (`Position 0) 35 | | `Position i -> 36 | if i < String.length s then 37 | (pos, `Char s.[i]) :: finish s (`Position (i+1)) 38 | else 39 | finish s `End 40 | 41 | let make_end_branch s pos x = 42 | match finish s pos with 43 | [] -> `Leaf x 44 | | l -> `Branch (l, `Leaf x) 45 | 46 | 47 | (* 48 | Create branches where possible. 49 | As a result, all the nodes become part of a branch. 50 | *) 51 | let rec make_branches (x : 'a tree) : 'a tree = 52 | match x with 53 | `Leaf _ -> x 54 | | `Branch (l, x) -> 55 | (match make_branches x with 56 | `Branch (l2, x2) -> `Branch ((l @ l2), x2) 57 | | x -> `Branch (l, x)) 58 | | `Node (pos, [ value, x ]) -> 59 | (match make_branches x with 60 | `Branch (l2, x2) -> `Branch (((pos, value) :: l2), x2) 61 | | x -> `Branch ([pos, value], x)) 62 | | `Node (pos, l) -> 63 | `Node (pos, List.map (fun (value, x) -> (value, make_branches x)) l) 64 | 65 | 66 | let make_initial_tree l : 'a tree = 67 | let rec aux i = function 68 | [] -> assert false 69 | | [ (s, x) ] -> 70 | let pos = 71 | if i < String.length s then `Position i 72 | else `End 73 | in 74 | make_end_branch s pos x 75 | 76 | | ((s, _) :: _) as l -> 77 | if i < String.length s then 78 | let groups = group_by (fun (s, _) -> `Char s.[i]) l in 79 | `Node (`Position i, 80 | List.map (fun (k, l) -> (k, aux (i+1) l)) groups) 81 | else 82 | (* reached end of string but multiple strings remain *) 83 | invalid_arg (sprintf "String_match.make_tree: duplicate key %S" s) 84 | in 85 | match l with 86 | [] -> `Node (`Length, []) 87 | | [ (s, x) ] -> make_end_branch s `Length x 88 | | l -> 89 | let groups = group_by (fun (s, _) -> `Int (String.length s)) l in 90 | `Node (`Length, 91 | List.map (fun (k, l) -> (k, aux 0 l)) groups) 92 | 93 | let make_tree l = 94 | make_branches (make_initial_tree l) 95 | 96 | 97 | 98 | let test () = 99 | let l = [ 100 | "abcdeg"; 101 | "abcdef"; 102 | "abdefh"; 103 | "bcd"; 104 | ""; 105 | ] 106 | in 107 | make_tree (List.map (fun s -> (s, s)) l) 108 | 109 | 110 | let get_value string_id pos_id pos = 111 | match pos with 112 | `Length -> "len" 113 | | `Position i -> 114 | if i = 0 then 115 | sprintf "String.unsafe_get %s %s" string_id pos_id 116 | else 117 | sprintf "String.unsafe_get %s (%s+%i)" string_id pos_id i 118 | | `End -> assert false 119 | 120 | let make_pattern value = 121 | match value with 122 | `Int i -> string_of_int i 123 | | `Char c -> sprintf "%C" c 124 | 125 | let cond test if_true if_false = 126 | [ 127 | `Line (sprintf "if %s then (" test); 128 | `Block if_true; 129 | `Line ")"; 130 | `Line "else ("; 131 | `Block if_false; 132 | `Line ")"; 133 | ] 134 | 135 | let make_branch_test string_id pos_id = function 136 | (`Length, `Int n) -> sprintf "len = %i" n 137 | | (`Position i, `Char c) -> 138 | if i = 0 then 139 | sprintf "String.unsafe_get %s %s = %C" string_id pos_id c 140 | else 141 | sprintf "String.unsafe_get %s (%s+%i) = %C" string_id pos_id i c 142 | | _ -> assert false 143 | 144 | let make_branch_tests string_id pos_id l = 145 | String.concat " && " (List.map (make_branch_test string_id pos_id) l) 146 | 147 | let rec map_to_ocaml string_id pos_id e = function 148 | `Leaf expr -> expr 149 | 150 | | `Branch (l, x) -> 151 | cond (make_branch_tests string_id pos_id l) 152 | (map_to_ocaml string_id pos_id e x) 153 | e 154 | 155 | | `Node (pos, l) -> 156 | [ 157 | `Line (sprintf "match %s with" (get_value string_id pos_id pos)); 158 | `Block [ 159 | `Inline (List.map (make_case string_id pos_id e) l); 160 | `Line "| _ -> ("; 161 | `Block [ 162 | `Block e; 163 | `Line ")"; 164 | ]; 165 | ] 166 | ] 167 | 168 | and make_case string_id pos_id e (value, tree) = 169 | `Inline [ 170 | `Line (sprintf "| %s -> (" (make_pattern value)); 171 | `Block [ 172 | `Block (map_to_ocaml string_id pos_id e tree); 173 | `Line ")"; 174 | ]; 175 | ] 176 | 177 | 178 | type exit_with = 179 | [ `Exn of string 180 | | `Expr ] 181 | 182 | let make_ocaml_expr_factored 183 | ?(string_id = "s") 184 | ?(pos_id = "pos") 185 | ?(len_id = "len") 186 | ?(exit_with = `Exn "Exit") 187 | ~error_expr 188 | cases : Ag_indent.t list = 189 | 190 | let exit_expr, catch = 191 | match exit_with with 192 | `Expr -> error_expr, (fun x -> x) 193 | | `Exn error_exn -> 194 | let exit_expr = [ `Line (sprintf "raise (%s)" error_exn) ] in 195 | let catch x = 196 | [ 197 | `Line "try"; 198 | `Block x; 199 | `Line (sprintf "with %s -> (" error_exn); 200 | `Block [ 201 | `Block error_expr; 202 | `Line ")"; 203 | ]; 204 | ] 205 | in 206 | exit_expr, catch 207 | in 208 | let cases = List.(rev (fold_left (fun list -> function 209 | | (Some s, x) -> (s, x)::list 210 | | (None, _) -> list 211 | ) [] cases)) in 212 | match cases with 213 | [] -> error_expr 214 | | l -> 215 | catch (map_to_ocaml string_id pos_id exit_expr (make_tree cases)) 216 | 217 | let test () = 218 | let l = [ 219 | "abc"; 220 | "abcd"; 221 | "abde"; 222 | "bcd"; 223 | ""; 224 | ] 225 | in 226 | let cases = 227 | List.map 228 | (fun s -> (Some s, [ `Line (sprintf "Some `Case_%s" s) ])) 229 | l 230 | in 231 | let expr = 232 | make_ocaml_expr_factored 233 | ~error_expr:[ `Line "None" ] 234 | cases 235 | in 236 | Atd_indent.to_stdout (List.map Ag_indent.strip expr) 237 | 238 | 239 | let make_ocaml_expr_naive 240 | ?(string_id = "s") 241 | ?(pos_id = "pos") 242 | ?(len_id = "len") 243 | ~error_expr 244 | cases = 245 | let map = function 246 | | (Some s, expr) -> 247 | `Inline [ 248 | `Line (sprintf "| %S ->" s); 249 | `Block expr; 250 | ] 251 | | (None, _expr) -> `Inline [] 252 | in 253 | [ 254 | `Line (sprintf "match %s with" string_id); 255 | `Block [ 256 | `Inline (List.map map cases); 257 | `Line "| _ ->"; 258 | `Block error_expr; 259 | ] 260 | ] 261 | 262 | 263 | let make_ocaml_expr 264 | ~optimized 265 | ?string_id 266 | ?pos_id 267 | ?len_id 268 | ?exit_with 269 | ~error_expr 270 | cases : Ag_indent.t list = 271 | 272 | if optimized then 273 | make_ocaml_expr_factored 274 | ?string_id ?pos_id ?len_id ?exit_with ~error_expr cases 275 | else 276 | make_ocaml_expr_naive 277 | ?string_id ?pos_id ?len_id ~error_expr cases 278 | 279 | 280 | let make_ocaml_int_mapping 281 | ?(string_id = "s") 282 | ?(pos_id = "pos") 283 | ?(len_id = "len") 284 | ?exit_with 285 | ~error_expr1 286 | ?(error_expr2 = [ `Line "assert false" ]) 287 | ?(int_id = "i") 288 | cases : Ag_indent.t list * Ag_indent.t list = 289 | 290 | let a = Array.of_list cases in 291 | let int_cases = 292 | Array.mapi (fun i (s, x) -> (s, [ `Line (string_of_int i) ])) a 293 | in 294 | let int_mapping_body = 295 | make_ocaml_expr_factored 296 | ~string_id 297 | ~pos_id 298 | ~len_id 299 | ?exit_with 300 | ~error_expr: error_expr1 301 | (Array.to_list int_cases) 302 | in 303 | let int_mapping_function = 304 | [ 305 | `Line (sprintf "fun %s %s %s ->" string_id pos_id len_id); 306 | `Block [ 307 | `Line ( 308 | sprintf "if %s < 0 || %s < 0 || %s + %s > String.length %s then" 309 | pos_id len_id pos_id len_id string_id 310 | ); 311 | `Block [ 312 | `Line "invalid_arg \"out-of-bounds substring position or length\";"; 313 | ]; 314 | `Inline int_mapping_body; 315 | ]; 316 | ] 317 | in 318 | let int_matching_cases = 319 | Array.mapi ( 320 | fun i (s, x) -> 321 | `Inline [ 322 | `Line (sprintf "| %i ->" i); 323 | `Block x; 324 | ] 325 | ) a 326 | in 327 | let int_matching = 328 | [ 329 | `Line (sprintf "match %s with" int_id); 330 | `Block [ 331 | `Inline (Array.to_list int_matching_cases); 332 | `Line "| _ -> ("; 333 | `Block [ 334 | `Block error_expr2; 335 | `Line ")"; 336 | ]; 337 | ]; 338 | ] 339 | in 340 | int_mapping_function, int_matching 341 | -------------------------------------------------------------------------------- /src/ag_string_match.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | Compilation of string pattern matching into something 4 | supposedly faster than what ocamlopt does. 5 | *) 6 | 7 | type position = [ `Length | `Position of int | `End ] 8 | type value = [ `Int of int | `Char of char ] 9 | 10 | type 'a tree = 11 | [ `Node of (position * (value * 'a tree) list) 12 | | `Branch of ((position * value) list * 'a tree) 13 | | `Leaf of 'a ] 14 | 15 | val make_tree : (string * 'a) list -> 'a tree 16 | 17 | type exit_with = 18 | [ `Exn of string 19 | | `Expr ] 20 | (** [`Exn s] raises an exception for each failure branch, and this 21 | exception is caught in one place, avoiding duplication of the 22 | [error_expr] expression. 23 | 24 | [`Expr] uses the [error_expr] in each failure branch, 25 | resulting in code duplication but avoiding raising and 26 | catching an exception. Suitable for fixed-length values 27 | for which code duplication is tolerable. 28 | *) 29 | 30 | val make_ocaml_expr_factored : 31 | ?string_id: string -> 32 | ?pos_id: string -> 33 | ?len_id: string -> 34 | ?exit_with: exit_with -> 35 | error_expr: Ag_indent.t list -> 36 | (string option * Ag_indent.t list) list -> Ag_indent.t list 37 | 38 | val make_ocaml_expr_naive : 39 | ?string_id: string -> 40 | ?pos_id: string -> 41 | ?len_id: string -> 42 | error_expr: Ag_indent.t list -> 43 | (string option * Ag_indent.t list) list -> Ag_indent.t list 44 | 45 | val make_ocaml_expr : 46 | optimized: bool -> 47 | ?string_id: string -> 48 | ?pos_id: string -> 49 | ?len_id: string -> 50 | ?exit_with: exit_with -> 51 | error_expr: Ag_indent.t list -> 52 | (string option * Ag_indent.t list) list -> Ag_indent.t list 53 | 54 | 55 | val make_ocaml_int_mapping : 56 | ?string_id: string -> 57 | ?pos_id: string -> 58 | ?len_id: string -> 59 | ?exit_with: exit_with -> 60 | error_expr1: Ag_indent.t list -> 61 | ?error_expr2: Ag_indent.t list -> 62 | ?int_id: string -> 63 | (string option * Ag_indent.t list) list -> 64 | 65 | (Ag_indent.t list * Ag_indent.t list) 66 | (* 67 | takes a list of cases, each being defined by a string to match against 68 | and by a corresponding expression of type 'a. 69 | 70 | returns: 71 | - function expression of type string -> int -> int -> int 72 | (maps a substring to an int corresponding to one of the strings 73 | to match against) 74 | 75 | - match-with expression of type 'a 76 | (matches s against the ints corresponding to the strings to match 77 | against) 78 | 79 | The whole point is to read records or variants without 80 | creating new strings or closures. 81 | *) 82 | -------------------------------------------------------------------------------- /src/ag_util.ml: -------------------------------------------------------------------------------- 1 | 2 | type 'a ocaml_array = 'a array 3 | 4 | let input_file fname read = 5 | let ic = open_in_bin fname in 6 | try 7 | let x = read ic in 8 | close_in ic; 9 | x 10 | with e -> 11 | close_in_noerr ic; 12 | raise e 13 | 14 | let output_file fname write = 15 | let oc = open_out_bin fname in 16 | try 17 | write oc; 18 | close_out oc 19 | with e -> 20 | close_out_noerr oc; 21 | raise e 22 | 23 | module Biniou = 24 | struct 25 | type 'a reader = Bi_inbuf.t -> 'a 26 | type 'a writer = Bi_outbuf.t -> 'a -> unit 27 | 28 | let from_channel ?len ?(shrlen = 0) read ic = 29 | let ib = Bi_inbuf.from_channel ?len ~shrlen ic in 30 | read ib 31 | 32 | let from_file ?len ?(shrlen = 0) read fname = 33 | input_file fname (fun ic -> from_channel ?len ~shrlen read ic) 34 | 35 | let to_channel ?len ?(shrlen = 0) write oc x = 36 | let ob = Bi_outbuf.create_channel_writer ?len ~shrlen oc in 37 | write ob x; 38 | Bi_outbuf.flush_channel_writer ob 39 | 40 | let to_file ?len ?(shrlen = 0) write fname x = 41 | output_file fname (fun oc -> to_channel ?len ~shrlen write oc x) 42 | end 43 | 44 | module Json = 45 | struct 46 | type 'a reader = Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a 47 | type 'a writer = Bi_outbuf.t -> 'a -> unit 48 | 49 | let finish ls lexbuf = 50 | Yojson.Safe.read_space ls lexbuf; 51 | if not (Yojson.Safe.read_eof lexbuf) then 52 | Yojson.json_error "Junk after end of JSON value" 53 | 54 | let from_lexbuf ?(stream = false) read ls lexbuf = 55 | Yojson.Safe.read_space ls lexbuf; 56 | 57 | let x = 58 | if Yojson.Safe.read_eof lexbuf then 59 | raise Yojson.End_of_input 60 | else 61 | read ls lexbuf 62 | in 63 | 64 | if not stream then 65 | finish ls lexbuf; 66 | 67 | x 68 | 69 | let from_string ?buf ?fname ?lnum read s = 70 | let lexbuf = Lexing.from_string s in 71 | let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in 72 | from_lexbuf read ls lexbuf 73 | 74 | let from_channel ?buf ?fname ?lnum read ic = 75 | let lexbuf = Lexing.from_channel ic in 76 | let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in 77 | from_lexbuf read ls lexbuf 78 | 79 | let from_file ?buf ?fname:src ?lnum read fname = 80 | let fname0 = 81 | match src with 82 | None -> fname 83 | | Some s -> s 84 | in 85 | input_file fname (fun ic -> from_channel ?buf ~fname:fname0 ?lnum read ic) 86 | 87 | let stream_from_lexbuf ?(fin = fun () -> ()) read ls lexbuf = 88 | let stream = Some true in 89 | let rec f i = 90 | try Some (from_lexbuf ?stream read ls lexbuf) 91 | with 92 | Yojson.End_of_input -> 93 | fin (); 94 | None 95 | | e -> 96 | (try fin () with _ -> ()); 97 | raise e 98 | in 99 | Stream.from f 100 | 101 | let stream_from_string ?buf ?fin ?fname ?lnum read ic = 102 | let lexbuf = Lexing.from_string ic in 103 | let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in 104 | stream_from_lexbuf ?fin read ls lexbuf 105 | 106 | let stream_from_channel ?buf ?fin ?fname ?lnum read ic = 107 | let lexbuf = Lexing.from_channel ic in 108 | let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in 109 | stream_from_lexbuf ?fin read ls lexbuf 110 | 111 | let stream_from_file ?buf ?(fin = fun () -> ()) ?fname:src ?lnum read fname = 112 | let fname0 = 113 | match src with 114 | None -> fname 115 | | Some s -> s 116 | in 117 | let ic = open_in_bin fname in 118 | let fin () = close_in_noerr ic; fin () in 119 | stream_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic 120 | 121 | let list_from_string ?buf ?fin ?fname ?lnum read ic = 122 | let stream = stream_from_string ?buf ?fin ?fname ?lnum read ic in 123 | let acc = ref [] in 124 | Stream.iter (fun x -> acc := x :: !acc) stream; 125 | List.rev !acc 126 | 127 | let list_from_channel ?buf ?fin ?fname ?lnum read ic = 128 | let stream = stream_from_channel ?buf ?fin ?fname ?lnum read ic in 129 | let acc = ref [] in 130 | Stream.iter (fun x -> acc := x :: !acc) stream; 131 | List.rev !acc 132 | 133 | let list_from_file ?buf ?fname:src ?lnum read fname = 134 | let fname0 = 135 | match src with 136 | None -> fname 137 | | Some s -> s 138 | in 139 | let ic = open_in_bin fname in 140 | let fin () = close_in_noerr ic in 141 | list_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic 142 | 143 | let to_string ?(len = 1024) write x = 144 | let ob = Bi_outbuf.create len in 145 | write ob x; 146 | Bi_outbuf.contents ob 147 | 148 | let to_channel ?len write oc x = Biniou.to_channel ?len ~shrlen:0 write oc x 149 | let to_file ?len write fname x = Biniou.to_file ?len ~shrlen:0 write fname x 150 | 151 | let stream_to_string ?(len = 1024) ?(lf = "\n") write stream = 152 | let ob = Bi_outbuf.create len in 153 | Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream; 154 | Bi_outbuf.contents ob 155 | 156 | let stream_to_channel ?len ?(lf = "\n") write oc stream = 157 | let ob = Bi_outbuf.create_channel_writer ?len ~shrlen:0 oc in 158 | Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream; 159 | Bi_outbuf.flush_channel_writer ob 160 | 161 | let stream_to_file ?len ?lf write fname stream = 162 | output_file fname (fun oc -> stream_to_channel ?len ?lf write oc stream) 163 | 164 | let list_to_string ?len ?lf write l = 165 | stream_to_string ?len ?lf write (Stream.of_list l) 166 | 167 | let list_to_channel ?len ?lf write oc l = 168 | stream_to_channel ?len ?lf write oc (Stream.of_list l) 169 | 170 | let list_to_file ?len ?lf write fname l = 171 | stream_to_file ?len ?lf write fname (Stream.of_list l) 172 | 173 | let preset_unknown_field_handler loc name = 174 | let msg = 175 | Printf.sprintf 176 | "Found unknown JSON field %s while expecting type defined at: %s" 177 | name loc 178 | in 179 | failwith msg 180 | 181 | let unknown_field_handler = ref preset_unknown_field_handler 182 | 183 | let preset_constr_mismatch_handler 184 | constr_field constr_constr value_field value_constr = 185 | let msg = 186 | Printf.sprintf 187 | "Field %s has constructor %s but field %s expects constructor %s" 188 | value_field value_constr constr_field constr_constr 189 | in 190 | Ag_oj_run.error msg 191 | 192 | let constr_mismatch_handler = ref preset_constr_mismatch_handler 193 | end 194 | 195 | module Validation = 196 | struct 197 | type path_elem = [ `Field of string | `Index of int ] 198 | type path = path_elem list 199 | 200 | let string_of_path l = 201 | String.concat "" ( 202 | List.rev_map ( 203 | function 204 | | `Field s -> "." ^ s 205 | | `Index n -> "[" ^ string_of_int n ^ "]" 206 | ) l 207 | ) 208 | 209 | type error = { 210 | error_path : path; 211 | error_msg : string option; 212 | } 213 | 214 | let error ?msg path = { 215 | error_path = path; 216 | error_msg = msg; 217 | } 218 | 219 | let string_of_error x = 220 | let path = string_of_path x.error_path in 221 | match x.error_msg with 222 | None -> 223 | "Validation error; path = " ^ path 224 | | Some msg -> 225 | Printf.sprintf "Validation error: %s; path = %s" msg path 226 | end 227 | -------------------------------------------------------------------------------- /src/ag_util.mli: -------------------------------------------------------------------------------- 1 | (** Various convenience types and functions *) 2 | 3 | type 'a ocaml_array = 'a array 4 | (** An alias for OCaml's standard array type, 5 | used in generated code. *) 6 | 7 | module Biniou : 8 | sig 9 | type 'a reader = Bi_inbuf.t -> 'a 10 | (** Type of a [read_] function as produced by [atdgen -biniou]. *) 11 | 12 | type 'a writer = Bi_outbuf.t -> 'a -> unit 13 | (** Type of a [write_] function as produced by [atdgen -biniou]. *) 14 | 15 | val from_channel : 16 | ?len:int -> 17 | ?shrlen:int -> 18 | 'a reader -> in_channel -> 'a 19 | (** Read a biniou value from a channel. 20 | @param len input buffer length. 21 | @param shrlen obsolete and ignored. 22 | *) 23 | 24 | val from_file : 25 | ?len:int -> 26 | ?shrlen:int -> 27 | 'a reader -> string -> 'a 28 | (** Read a biniou value from a file. 29 | @param len input buffer length. 30 | @param shrlen obsolete and ignored. 31 | *) 32 | 33 | val to_channel : 34 | ?len:int -> 35 | ?shrlen:int -> 36 | 'a writer -> out_channel -> 'a -> unit 37 | (** Write a biniou value to a channel. 38 | @param len output buffer length. 39 | @param shrlen obsolete and ignored. 40 | *) 41 | 42 | val to_file : 43 | ?len:int -> 44 | ?shrlen:int -> 45 | 'a writer -> string -> 'a -> unit 46 | (** Write a biniou value to a file. 47 | @param len output buffer length. 48 | @param shrlen obsolete and ignored. 49 | *) 50 | end 51 | 52 | module Json : 53 | sig 54 | type 'a reader = Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a 55 | (** Type of a [read_] function as produced by [atdgen -json]. 56 | 57 | In versions of yojson greater than 1.0.1, 58 | type [Yojson.Safe.lexer_state] is equivalent to 59 | [Yojson.lexer_state], [Yojson.Basic.lexer_state] and 60 | [Yojson.Raw.lexer_state]. *) 61 | 62 | type 'a writer = Bi_outbuf.t -> 'a -> unit 63 | (** Type of a [write_] function as produced by [atdgen -json]. *) 64 | 65 | val from_lexbuf : 66 | ?stream:bool -> 67 | 'a reader -> Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a 68 | (** Read a JSON value from a lexbuf. 69 | @param stream if [true], the JSON parser will not try 70 | to consume whitespace until the end of file. 71 | Default is [false], which raises a [Yojson.Json_error] 72 | exception if the valid JSON value is followed 73 | by anything other than standard JSON whitespace. 74 | *) 75 | 76 | val from_string : 77 | ?buf:Bi_outbuf.t -> 78 | ?fname:string -> 79 | ?lnum:int -> 80 | 'a reader -> string -> 'a 81 | (** Convert a JSON value from a string. 82 | @param buf buffer used to accumulate string data 83 | during the lexing phase. 84 | @param fname input file name to be used in error messages. 85 | It does not have to be the name of a real file, 86 | it can be something like [""]. 87 | @param lnum line number to assign to the first line of input. 88 | For example [lnum=10] means that an error on the first 89 | line of input will be reported as an error on line 10. 90 | Default: 1. 91 | *) 92 | 93 | val from_channel : 94 | ?buf:Bi_outbuf.t -> 95 | ?fname:string -> 96 | ?lnum:int -> 97 | 'a reader -> in_channel -> 'a 98 | (** Read a JSON value from a channel. 99 | @param buf buffer used to accumulate string data 100 | during the lexing phase. 101 | @param fname input file name to be used in error messages. 102 | It does not have to be the name of a real file, 103 | it can be something like [""]. 104 | @param lnum line number to assign to the first line of input. 105 | For example [lnum=10] means that an error on the first 106 | line of input will be reported as an error on line 10. 107 | Default: 1. 108 | *) 109 | 110 | val from_file : 111 | ?buf:Bi_outbuf.t -> 112 | ?fname:string -> 113 | ?lnum:int -> 114 | 'a reader -> string -> 'a 115 | (** Read a JSON value from a channel. 116 | @param buf buffer used to accumulate string data 117 | during the lexing phase. 118 | @param fname input file name to be used in error messages. 119 | It is intended to represent the source file 120 | if it is different from the input file. 121 | @param lnum line number to assign to the first line of input. 122 | For example [lnum=10] means that an error on the first 123 | line of input will be reported as an error on line 10. 124 | Default: 1. 125 | *) 126 | 127 | val stream_from_lexbuf : 128 | ?fin:(unit -> unit) -> 129 | 'a reader -> Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a Stream.t 130 | (** Read a stream of JSON values from a lexbuf. 131 | @param fin finalization function executed once when the end of the 132 | stream is reached either because there is no more 133 | input or because of an exception. This is typically 134 | used to close the input channel, e.g. 135 | [fun () -> close_in_noerr ic]. 136 | *) 137 | 138 | val stream_from_string : 139 | ?buf:Bi_outbuf.t -> 140 | ?fin:(unit -> unit) -> 141 | ?fname:string -> 142 | ?lnum:int -> 143 | 'a reader -> string -> 'a Stream.t 144 | (** Read a stream of JSON values from a channel. 145 | Values do not have to be separated by newline characters. 146 | @param buf buffer used to accumulate string data 147 | during the lexing phase. 148 | @param fin finalization function executed once when the end of the 149 | stream is reached either because there is no more 150 | input or because of an exception. This is typically 151 | used to free the underlying resources, if any. 152 | @param fname input file name to be used in error messages. 153 | It does not have to be the name of a real file, 154 | it can be something like [""]. 155 | @param lnum line number to assign to the first line of input. 156 | For example [lnum=10] means that an error on the first 157 | line of input will be reported as an error on line 10. 158 | Default: 1. 159 | *) 160 | 161 | val stream_from_channel : 162 | ?buf:Bi_outbuf.t -> 163 | ?fin:(unit -> unit) -> 164 | ?fname:string -> 165 | ?lnum:int -> 166 | 'a reader -> in_channel -> 'a Stream.t 167 | (** Read a stream of JSON values from a channel. 168 | Values do not have to be separated by newline characters. 169 | @param buf buffer used to accumulate string data 170 | during the lexing phase. 171 | @param fin finalization function executed once when the end of the 172 | stream is reached either because there is no more 173 | input or because of an exception. This is typically 174 | used to close the input channel, e.g. 175 | [fun () -> close_in_noerr ic]. 176 | @param fname input file name to be used in error messages. 177 | It does not have to be the name of a real file, 178 | it can be something like [""]. 179 | @param lnum line number to assign to the first line of input. 180 | For example [lnum=10] means that an error on the first 181 | line of input will be reported as an error on line 10. 182 | Default: 1. 183 | *) 184 | 185 | val stream_from_file : 186 | ?buf:Bi_outbuf.t -> 187 | ?fin:(unit -> unit) -> 188 | ?fname:string -> 189 | ?lnum:int -> 190 | 'a reader -> string -> 'a Stream.t 191 | (** Read a stream of JSON values from a file. 192 | Values do not have to be separated by newline characters. 193 | @param buf buffer used to accumulate string data 194 | during the lexing phase. 195 | @param fin finalization function executed once when the end of the 196 | stream is reached either because there is no more 197 | input or because of an exception. This can be used 198 | to remove the input file if it was temporary, e.g. 199 | [fun () -> Sys.remove fname]. 200 | @param fname input file name to be used in error messages. 201 | It is intended to represent the source file 202 | if it is different from the input file. 203 | @param lnum line number to assign to the first line of input. 204 | For example [lnum=10] means that an error on the first 205 | line of input will be reported as an error on line 10. 206 | Default: 1. 207 | *) 208 | 209 | val list_from_string : 210 | ?buf:Bi_outbuf.t -> 211 | ?fin:(unit -> unit) -> 212 | ?fname:string -> 213 | ?lnum:int -> 214 | 'a reader -> string -> 'a list 215 | (** Read a list of JSON values from a channel. 216 | Values do not have to be separated by newline characters. 217 | @param buf buffer used to accumulate string data 218 | during the lexing phase. 219 | @param fin finalization function executed once when the end of the 220 | stream is reached either because there is no more 221 | input or because of an exception. This is typically 222 | used to free the underlying resources, if any. 223 | @param fname input file name to be used in error messages. 224 | It does not have to be the name of a real file, 225 | it can be something like [""]. 226 | @param lnum line number to assign to the first line of input. 227 | For example [lnum=10] means that an error on the first 228 | line of input will be reported as an error on line 10. 229 | Default: 1. 230 | *) 231 | 232 | val list_from_channel : 233 | ?buf:Bi_outbuf.t -> 234 | ?fin:(unit -> unit) -> 235 | ?fname:string -> 236 | ?lnum:int -> 237 | 'a reader -> in_channel -> 'a list 238 | (** Read a list of JSON values from a channel. 239 | Values do not have to be separated by newline characters. 240 | @param buf buffer used to accumulate string data 241 | during the lexing phase. 242 | @param fin finalization function executed once when the end of the 243 | stream is reached either because there is no more 244 | input or because of an exception. This is typically 245 | used to close the input channel, e.g. 246 | [fun () -> close_in_noerr ic]. 247 | @param fname input file name to be used in error messages. 248 | It does not have to be the name of a real file, 249 | it can be something like [""]. 250 | @param lnum line number to assign to the first line of input. 251 | For example [lnum=10] means that an error on the first 252 | line of input will be reported as an error on line 10. 253 | Default: 1. 254 | *) 255 | 256 | val list_from_file : 257 | ?buf:Bi_outbuf.t -> 258 | ?fname:string -> 259 | ?lnum:int -> 260 | 'a reader -> string -> 'a list 261 | (** Read a list of JSON values from a file. 262 | Values do not have to be separated by newline characters. 263 | @param buf buffer used to accumulate string data 264 | during the lexing phase. 265 | @param fname input file name to be used in error messages. 266 | It is intended to represent the source file 267 | if it is different from the input file. 268 | @param lnum line number to assign to the first line of input. 269 | For example [lnum=10] means that an error on the first 270 | line of input will be reported as an error on line 10. 271 | Default: 1. 272 | *) 273 | 274 | val to_string : 275 | ?len:int -> 276 | 'a writer -> 'a -> string 277 | (** Write a JSON value to a string. 278 | @param len output buffer length. 279 | *) 280 | 281 | val to_channel : 282 | ?len:int -> 283 | 'a writer -> out_channel -> 'a -> unit 284 | (** Write a JSON value to a channel. 285 | @param len output buffer length. 286 | *) 287 | 288 | val to_file : 289 | ?len:int -> 290 | 'a writer -> string -> 'a -> unit 291 | (** Write a JSON value to a file. 292 | @param len output buffer length. 293 | *) 294 | 295 | val stream_to_string : 296 | ?len:int -> 297 | ?lf:string -> 298 | 'a writer -> 'a Stream.t -> string 299 | (** Write a stream of values to a string. 300 | @param len output buffer length. 301 | @param lf additional element terminator. Default: ["\n"]. 302 | *) 303 | 304 | val stream_to_channel : 305 | ?len:int -> 306 | ?lf:string -> 307 | 'a writer -> out_channel -> 'a Stream.t -> unit 308 | (** Write a stream of values to a channel. 309 | @param len output buffer length. 310 | @param lf additional element terminator. Default: ["\n"]. 311 | *) 312 | 313 | val stream_to_file : 314 | ?len:int -> 315 | ?lf:string -> 316 | 'a writer -> string -> 'a Stream.t -> unit 317 | (** Write a stream of values to a file. 318 | @param len output buffer length. 319 | @param lf additional element terminator. Default: ["\n"]. 320 | *) 321 | 322 | val list_to_string : 323 | ?len:int -> 324 | ?lf:string -> 325 | 'a writer -> 'a list -> string 326 | (** Write a list of values to a string. 327 | @param len output buffer length. 328 | @param lf additional element terminator. Default: ["\n"]. 329 | *) 330 | 331 | val list_to_channel : 332 | ?len:int -> 333 | ?lf:string -> 334 | 'a writer -> out_channel -> 'a list -> unit 335 | (** Write a list of values to a channel. 336 | @param len output buffer length. 337 | @param lf additional element terminator. Default: ["\n"]. 338 | *) 339 | 340 | val list_to_file : 341 | ?len:int -> 342 | ?lf:string -> 343 | 'a writer -> string -> 'a list -> unit 344 | (** Write a list of values to a file. 345 | @param len output buffer length. 346 | @param lf additional element terminator. Default: ["\n"]. 347 | *) 348 | 349 | 350 | val preset_unknown_field_handler : string -> string -> unit 351 | (** 352 | [preset_unknown_field_handler src_loc field_name] 353 | raises a [Failure] exception with a message containing 354 | the location of the type definition in the source ATD file 355 | ([src_loc]) and the name of the field ([field_name]). 356 | *) 357 | 358 | val unknown_field_handler : (string -> string -> unit) ref 359 | (** Function called when an unknown JSON field is encountered if 360 | the code was generated by atdgen -json-strict-fields. 361 | Its preset behavior is to call [preset_unknown_field_handler] 362 | which raises a [Failure] exception. 363 | 364 | Usage: [!Ag_util.Json.unknown_field_handler src_loc field_name] 365 | where [src_loc] is the location of the type definition 366 | in the source ATD file and [field_name] is the unknown 367 | JSON field name. 368 | *) 369 | 370 | val preset_constr_mismatch_handler : 371 | string -> string -> string -> string -> unit 372 | (** 373 | [preset_constr_mismatch_handler 374 | constr_field constr_constr value_field value_constr] 375 | raises a [Ag_oj_run.Error] exception with a message containing 376 | the constructor field and value ([constr_field] and [constr_constr]) 377 | which don't match the value field's ([value_field]) 378 | constructor ([value_constr]). 379 | *) 380 | 381 | val constr_mismatch_handler : 382 | (string -> string -> string -> string -> unit) ref 383 | (** Function called when an explicit constructor field value does not 384 | match the constructor used if the code was generated by atdgen 385 | -json-strict-constrs. Its preset behavior is to call 386 | [preset_unknown_field_handler] which raises a [Ag_oj_run.Error] 387 | exception. 388 | 389 | Usage: [!Ag_util.Json.constr_mismatch_handler 390 | constr_field constr_constr value_field value_constr] 391 | where [constr_field] is the name of the constructor field, 392 | [constr_constr] is the constructor field value, [value_field] is the 393 | name of the value field, and [value_constr] is the constructor used. 394 | *) 395 | end 396 | 397 | module Validation : 398 | sig 399 | type path_elem = [ `Field of string | `Index of int ] 400 | type path = path_elem list 401 | (** Path within a value, used to report validation errors. *) 402 | 403 | val string_of_path : path -> string 404 | (** Reverse and concatenate a path into a string 405 | such as [".settings.ports[0]"] *) 406 | 407 | type error = { 408 | error_path : path; 409 | error_msg : string option; 410 | } 411 | 412 | val error : ?msg: string -> path -> error 413 | val string_of_error : error -> string 414 | end 415 | -------------------------------------------------------------------------------- /src/ag_validate.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Mapping from ATD to "validate" 3 | *) 4 | 5 | open Printf 6 | 7 | type validate_repr = (string option * bool) 8 | (* (opt_v, b) 9 | is obtained by analyzing all available type definitions. 10 | The first value opt_v is the optional local validator 11 | coming from an ATD annotation (see `Local). 12 | The second value b is true iff the data doesn't need scanning. 13 | 14 | There are four cases: 15 | opt_v = None && b = true => no validation is needed at all 16 | opt_v = None && b = false => validators must be called on some 17 | sub-fields of the data 18 | opt_v <> None && b = true => the given validator must be called 19 | but there's no need to look into 20 | the sub-fields 21 | opt_v <> None && b = false => the given validator must be called 22 | in addition to scanning sub-fields 23 | *) 24 | 25 | let make_full_validator s = 26 | sprintf "\ 27 | fun path x -> \ 28 | if ( %s ) x then None \ 29 | else Some (Ag_util.Validation.error path)" 30 | s 31 | 32 | let get_validator an = 33 | let full = 34 | Atd_annot.get_field (fun s -> Some (Some s)) None 35 | ["ocaml"] "validator" an 36 | in 37 | match full with 38 | | Some _ -> full 39 | | None -> 40 | let shorthand = 41 | Atd_annot.get_field (fun s -> Some (Some s)) None 42 | ["ocaml"] "valid" an 43 | in 44 | match shorthand with 45 | | None -> None 46 | | Some s -> Some (make_full_validator s) 47 | -------------------------------------------------------------------------------- /src/ag_xb_emit.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Tools shared between code generators for the biniou serialization format. 3 | (xb means X-Biniou) 4 | *) 5 | 6 | open Printf 7 | open Ag_error 8 | open Ag_mapping 9 | 10 | type 'a expr = ('a, Ag_biniou.biniou_repr) Ag_mapping.mapping 11 | type 'a def = ('a, Ag_biniou.biniou_repr) Ag_mapping.def 12 | type 'a grouped_defs = (bool * 'a def list) list 13 | 14 | type name = (loc * string) 15 | 16 | type names = { 17 | field_names : name list list; 18 | variant_names : name list list; 19 | } 20 | 21 | let rec extract_names_from_expr acc (x : 'a expr) = 22 | match x with 23 | `Unit _ 24 | | `Bool _ 25 | | `Int _ 26 | | `Float _ 27 | | `String _ -> acc 28 | | `Sum (loc, va, _, _) -> 29 | let l, (fn, vn) = 30 | Array.fold_left extract_names_from_variant ([], acc) va 31 | in 32 | (fn, List.rev l :: vn) 33 | 34 | | `Record (loc, fa, _, _) -> 35 | let l, (fn, vn) = 36 | Array.fold_left extract_names_from_field ([], acc) fa 37 | in 38 | (List.rev l :: fn, vn) 39 | 40 | | `Tuple (loc, ca, _, _) -> 41 | Array.fold_left extract_names_from_cell acc ca 42 | 43 | | `List (loc, x, _, _) 44 | | `Option (loc, x, _, _) 45 | | `Nullable (loc, x, _, _) 46 | | `Wrap (loc, x, _, _) -> 47 | extract_names_from_expr acc x 48 | 49 | | `Name (loc, _, l, _, _) -> 50 | List.fold_left extract_names_from_expr acc l 51 | 52 | | `External (loc, _, l, _, _) -> 53 | List.fold_left extract_names_from_expr acc l 54 | 55 | | `Tvar _ -> acc 56 | 57 | and extract_names_from_variant (l, acc) x = 58 | let l = (x.var_loc, x.var_cons) :: l in 59 | match x.var_arg with 60 | None -> (l, acc) 61 | | Some x -> 62 | (l, extract_names_from_expr acc x) 63 | 64 | and extract_names_from_field (l, acc) x = 65 | let l = (x.f_loc, x.f_name) :: l in 66 | (l, extract_names_from_expr acc x.f_value) 67 | 68 | and extract_names_from_cell acc x = 69 | extract_names_from_expr acc x.cel_value 70 | 71 | 72 | let extract_ocaml_names_from_defs l = 73 | let fn, vn = 74 | List.fold_left ( 75 | fun acc def -> 76 | match def.def_value with 77 | None -> acc 78 | | Some x -> extract_names_from_expr acc x 79 | ) ([], []) l 80 | in 81 | { 82 | field_names = List.rev fn; 83 | variant_names = List.rev vn; 84 | } 85 | 86 | let flatten_defs (grouped_defs : 'a grouped_defs) : 'a def list = 87 | List.flatten (List.map snd grouped_defs) 88 | 89 | let check_duplicate_hashes kind l = 90 | let tbl = Hashtbl.create 100 in 91 | List.iter ( 92 | fun (loc, s) -> 93 | let h = Bi_io.hash_name s in 94 | try 95 | let loc0, s0 = Hashtbl.find tbl h in 96 | error2 97 | loc0 (sprintf "Definition of %s %s." kind s0) 98 | loc ( 99 | sprintf "\ 100 | Definition of %s %s. 101 | 102 | Both %s and %s have the same hash %i which 103 | makes them indistinguishable once in the Biniou format. 104 | Use different names." 105 | kind s 106 | s0 s h 107 | ) 108 | 109 | with Not_found -> 110 | Hashtbl.add tbl h (loc, s) 111 | ) l 112 | 113 | let check_hashes x = 114 | List.iter (check_duplicate_hashes "record field name") x.field_names; 115 | List.iter (check_duplicate_hashes "variant name") x.variant_names 116 | 117 | let check (l : 'a grouped_defs) = 118 | let x = extract_ocaml_names_from_defs (flatten_defs l) in 119 | check_hashes x 120 | 121 | (* 122 | let find_clashes () = 123 | let l = Mikmatch.Text.lines_of_file "/tmp/dictionary.txt" in 124 | (* 125 | let l1 = List.rev_map (fun s -> s ^ "1") l in 126 | let l2 = List.rev_map (fun s -> s ^ "2") l in 127 | let l3 = List.rev_map (fun s -> s ^ "3") l in 128 | let l4 = List.rev_map (fun s -> s ^ "4") l in 129 | let l = List.flatten [l; l1; l2; l3; l4] in 130 | *) 131 | let tbl = Hashtbl.create (2 * List.length l) in 132 | List.iter ( 133 | fun s -> 134 | let h = Bi_io.hash_name s in 135 | let r = 136 | try Hashtbl.find tbl h 137 | with Not_found -> 138 | let r = ref [] in 139 | Hashtbl.add tbl h r; 140 | r 141 | in 142 | r := s :: !r 143 | ) l; 144 | let clashes = 145 | Hashtbl.fold ( 146 | fun h r acc -> 147 | let l = !r in 148 | if List.length l >= 2 then 149 | List.rev l :: acc 150 | else 151 | acc 152 | ) tbl [] 153 | in 154 | let clashes = List.sort compare clashes in 155 | List.iter (fun l -> print_endline (String.concat " " l)) clashes 156 | *) 157 | 158 | (* 159 | Groups of words with identical biniou hashes obtained with find_clashes: 160 | 161 | bind1 classroom's3 162 | bind2 classroom's4 163 | commutes1 funerals4 164 | expect1 tantalus4 165 | idea chaw2 166 | interval's1 middling2 167 | interval's2 middling3 168 | interval's3 middling4 169 | militarily1 scheduled4 170 | overviews neglects3 171 | shea crew2 172 | vacating maxine3 173 | workshop1 examples3 174 | workshop2 examples4 175 | 176 | bevel reconveyed 177 | cogitate jutties 178 | premiums squigglier 179 | representationalists supervene 180 | *) 181 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | #require "unix" 3 | 4 | let version = 5 | let ic = open_in "../VERSION" in 6 | let version = input_line ic in 7 | close_in ic; 8 | version 9 | 10 | let () = Printf.ksprintf Jbuild_plugin.V1.send {| 11 | (jbuild_version 1) 12 | 13 | (ocamllex (ag_doc_lexer)) 14 | 15 | (rule 16 | ((targets (ag_version.ml)) 17 | (action 18 | (with-stdout-to ${@} 19 | (echo "let version = \"%s\""))))) 20 | 21 | (library 22 | ((name atdgen) 23 | (public_name atdgen) 24 | (wrapped false) 25 | (libraries (atd str biniou yojson)))) 26 | |} version 27 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | test-2.bin 2 | test-2.json 3 | test-json-files.json 4 | test-json-streams.json 5 | test-std.json 6 | test.bin 7 | test.json 8 | test.ml 9 | test.mli 10 | test2.ml 11 | test2.mli 12 | test2j.ml 13 | test2j.mli 14 | test3j.ml 15 | test3j.mli 16 | test4.ml 17 | test4.mli 18 | test4j.ml 19 | test4j.mli 20 | test5_b.ml 21 | test5_b.mli 22 | test5_j.ml 23 | test5_j.mli 24 | test5_t.ml 25 | test5_t.mli 26 | test_atdgen 27 | testdoc 28 | testj.ml 29 | testj.mli 30 | testjstd.ml 31 | testjstd.mli 32 | testv.ml 33 | testv.mli 34 | test3j_*.ml* 35 | test_type_conv_*.ml* 36 | test_atdgen_type_conv 37 | -------------------------------------------------------------------------------- /test/benchmark.ml: -------------------------------------------------------------------------------- 1 | 2 | open Printf 3 | 4 | (*** Type definitions for json-static ***) 5 | 6 | open Test 7 | 8 | module C = 9 | struct 10 | type t = char 11 | let to_json x = Json_type.Int (Char.code x) 12 | let of_json = function 13 | Json_type.Int i when i >= 0 && i < 256 -> (Char.chr i) 14 | | _ -> failwith "corrupted json char" 15 | let t = `Int 16 | end 17 | 18 | module I32 = 19 | struct 20 | type t = int32 21 | let to_json x = Json_type.String (Int32.to_string x) 22 | let of_json = function 23 | Json_type.String s -> (Int32.of_string s) 24 | | _ -> failwith "corrupted json int32" 25 | let t = `String 26 | end 27 | 28 | module I64 = 29 | struct 30 | type t = int64 31 | let to_json x = Json_type.String (Int64.to_string x) 32 | let of_json = function 33 | Json_type.String s -> (Int64.of_string s) 34 | | _ -> failwith "corrupted json int64" 35 | let t = `String 36 | end 37 | 38 | let json_of_unit () = Json_type.Null 39 | let unit_of_json = function 40 | Json_type.Null -> () 41 | | _ -> failwith "error: expected null" 42 | 43 | type json test_variant = predefined 44 | [ `Case1 | `Case2 of int | `Case3 of string | `Case4 of test_variant list ] 45 | 46 | and mixed_record = predefined { 47 | ?field0 : int option; 48 | ?field1 : float option; 49 | field2 : string option; 50 | field3 : I64.t; 51 | field4 : float array; 52 | ?field5 : bool option; 53 | ?field6 : string option; 54 | field7 : test_variant; 55 | field8 : string array; 56 | field9 : ( 57 | int 58 | * int 59 | * C.t 60 | * int 61 | * I32.t 62 | * I64.t 63 | ); 64 | field10 : bool; 65 | ?field11 : bool = false; 66 | field12 : unit list; 67 | field13 : string option list 68 | } 69 | 70 | and mixed = (mixed_record array * mixed_record array) list 71 | 72 | 73 | 74 | (*** Creation of sample data for testing ***) 75 | 76 | let make_mixed_record_array n = 77 | Array.init n ( 78 | fun i -> 79 | { 80 | field0 = Some i; 81 | field1 = Some 0.555; 82 | field2 = Some (String.copy "abcdefghijklmnopqrstuvwxyz"); 83 | field3 = 12345678L; 84 | field4 = [| 1.23; 3.45; 4.56 |]; 85 | field5 = None; 86 | field6 = None; 87 | field7 = `Case4 [ `Case1; `Case2 999; `Case3 "abcdefghij"; `Case4 [] ]; 88 | field8 = [| "a"; "bc"; "def"; "ghij"; "klmno"; 89 | "pqrstu"; "vwxyz01"; "23456789" |]; 90 | field9 = ( 91 | 1_000_000, 92 | 0xff, 93 | '\xff', 94 | 0xffff, 95 | 0xffffffffl, 96 | 0xffffffffffffffffL 97 | ); 98 | field10 = true; 99 | field11 = false; 100 | field12 = [ (); () ]; 101 | field13 = [ Some "abcdefgh"; None; Some "qwerty" ] 102 | } 103 | ) 104 | 105 | let make_mixed ~top_len ~tab_len ~ar_len = 106 | Array.to_list ( 107 | Array.init top_len ( 108 | fun _ -> 109 | (make_mixed_record_array tab_len, make_mixed_record_array ar_len) 110 | ) 111 | ) 112 | 113 | 114 | (*** Benchmarking ***) 115 | 116 | let time s f x = 117 | printf "%s: %!" s; 118 | let t1 = Unix.gettimeofday () in 119 | let y = f x in 120 | let t2 = Unix.gettimeofday () in 121 | printf "%.3f s\n%!" (t2 -. t1); 122 | y 123 | 124 | let print_length label s = 125 | printf "%s len = %i\n" label (String.length s) 126 | 127 | let marshal_mixed x = 128 | let s = Marshal.to_string x [Marshal.No_sharing] in 129 | print_length "marshal" s; 130 | s 131 | 132 | let unmarshal_mixed s = 133 | (Marshal.from_string s 0 : mixed) 134 | 135 | let jsonstatic_of_mixed x = 136 | let s = Json_io.string_of_json ~compact:true (json_of_mixed x) in 137 | print_length "json-static" s; 138 | s 139 | 140 | let mixed_of_jsonstatic s = 141 | mixed_of_json (Json_io.json_of_string s) 142 | 143 | let biniou_of_mixed x = 144 | let s = Test.string_of_mixed ~len:10_000_000 x in 145 | print_length "atdgen-biniou" s; 146 | s 147 | 148 | let mixed_of_biniou s = 149 | Test.mixed_of_string s 150 | 151 | let atdgenjson_of_mixed x = 152 | let s = Testj.string_of_mixed ~len:10_000_000 x in 153 | print_length "atdgen-json" s; 154 | s 155 | 156 | let mixed_of_atdgenjson s = 157 | Testj.mixed_of_string s 158 | 159 | let compact () = 160 | printf "[compaction]\n%!"; 161 | Gc.compact () 162 | 163 | let single_perf_test () = 164 | let x = make_mixed ~top_len:100 ~tab_len:500 ~ar_len:500 in 165 | if true then ( 166 | compact (); 167 | let marshal_s = time "marshal write" marshal_mixed x in 168 | compact (); 169 | ignore (time "marshal read" unmarshal_mixed marshal_s); 170 | ); 171 | if true then ( 172 | compact (); 173 | let biniou_s = time "atdgen-biniou write" biniou_of_mixed x in 174 | compact (); 175 | ignore (time "atdgen-biniou read" mixed_of_biniou biniou_s); 176 | ); 177 | if true then ( 178 | compact (); 179 | let json_s = time "atdgen-json write" atdgenjson_of_mixed x in 180 | compact (); 181 | ignore (time "atdgen-json read" mixed_of_atdgenjson json_s); 182 | ); 183 | if true then ( 184 | compact (); 185 | let json_s = time "json-static write" jsonstatic_of_mixed x in 186 | compact (); 187 | ignore (time "json-static read" mixed_of_jsonstatic json_s); 188 | ) 189 | 190 | let perf_test () = 191 | Gc.set { (Gc.get()) with Gc.verbose = 0x020 }; 192 | let n = 2 in 193 | for i = 1 to n do 194 | printf "[run %i/%i]\n%!" i n; 195 | if i = 2 then 196 | Gc.set { (Gc.get()) with Gc.space_overhead = 500 }; 197 | single_perf_test () 198 | done 199 | 200 | 201 | let () = perf_test () 202 | -------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (rule 4 | ((targets (test.ml test.mli)) 5 | (deps (test.atd)) 6 | (action (run ${bin:atdgen} ${<})))) 7 | 8 | (rule 9 | ((targets (test2.ml test2.mli)) 10 | (deps (test2.atd)) 11 | (action (run ${bin:atdgen} -open Test ${<})))) 12 | 13 | (rule 14 | ((targets (testj.ml testj.mli)) 15 | (deps (test.atd test.ml test.mli)) 16 | (action 17 | (run 18 | ${bin:atdgen} -json -extend Test -j-custom-fields 19 | "fun loc s -> Printf.printf \"Warning: skipping field %s (def: %s)\" s loc" 20 | ${<} 21 | -o testj)))) 22 | 23 | (rule 24 | ((targets (test2j.ml test2j.mli)) 25 | (deps (test2.atd)) 26 | (action 27 | (run ${bin:atdgen} -json -std-json -o test2j -open Test,Test2,Testj -ntd ${<})))) 28 | 29 | (rule 30 | ((targets (test3j_t.ml test3j_t.mli)) 31 | (deps (test3j.atd)) 32 | (action (run ${bin:atdgen} -t ${<})))) 33 | 34 | (rule 35 | ((targets (test3j_j.ml test3j_j.mli)) 36 | (deps (test3j.atd)) 37 | (action (run ${bin:atdgen} -j -j-std -j-strict-constrs ${<})))) 38 | 39 | (rule 40 | ((targets (testjstd.ml testjstd.mli)) 41 | (deps (test.atd)) 42 | (action (run ${bin:atdgen} -std-json -extend Test test.atd -o testjstd)))) 43 | 44 | (rule 45 | ((targets (testv.ml testv.mli)) 46 | (deps (test.atd)) 47 | (action (run ${bin:atdgen} -validate -extend Test test.atd -o testv)))) 48 | 49 | (executables 50 | ((libraries (atd atdgen)) 51 | (names (test_atdgen_main)) 52 | (modules 53 | (test 54 | test3j_j 55 | test3j_t 56 | testjstd 57 | testj 58 | testv 59 | test_atdgen_main 60 | test_atdgen_type_conv 61 | test_lib)) 62 | (package atd))) 63 | 64 | (alias 65 | ((name runtest) 66 | (deps (test_atdgen_main.exe)) 67 | (action (run ${<})))) -------------------------------------------------------------------------------- /test/test.atd: -------------------------------------------------------------------------------- 1 | 2 | 3 | type def 4 | = abstract 5 | 24 | 25 | type r = { 26 | a : int ; 27 | b : bool; 28 | c : p; 29 | } 30 | 31 | type p = 32 | [ A | B of r | C ] 33 | 38 | 39 | type star_rating = int 40 | 41 | type p'' = int p' 42 | 43 | type 'a p' = [ A | Bb of 'a p' | Ccccc of 'a ] 44 | 45 | type hello = [ Hello of string | World ] 46 | 47 | type tup = (int * test) 48 | 49 | 50 | type test_variant = 51 | [ Case1 | Case2 of int | Case3 of string | Case4 of test_variant list ] 52 | 53 | type date = (int * int nullable * int nullable) 54 | 55 | type floats = { 56 | f32 : float ; 57 | f64 : float; 58 | } 59 | 60 | type mixed_record = { 61 | ?field0 : int option; 62 | ?field1 : float option; 63 | field2 : string option; 64 | field3 : int ; 65 | field4 : float list ; 66 | ?field5 : bool option; 67 | ?field6 : string option; 68 | field7 : test_variant; 69 | field8 : string list ; 70 | field9 : ( 71 | int 72 | * int 73 | * int 74 | * int 75 | 76 | * int 77 | * int 78 | ); 79 | field10 : bool; 80 | ~field11 : bool; 81 | field12 : unit list; 82 | field13 : string option list; 83 | field14 : date; 84 | } 85 | 86 | type mixed = 87 | (mixed_record list 88 | * mixed_record list ) list 89 | 90 | type test = { 91 | ?x0 : int option; 92 | ?x1 : float option; 93 | x2 : mixed; 94 | x3 : mixed_record list; 95 | x4 : int ; 96 | } 97 | 98 | type base = { 99 | b0 : int; 100 | b1 : bool; 101 | } 102 | 103 | type extended = { 104 | b0 : int; 105 | b1 : bool 106 | ; 109 | b2 : string; 110 | ?b3 : string option; 111 | b4 : string option; 112 | ~b5 : float; 113 | } = 0 then None 117 | else Some (Ag_util.Validation.error path)"> 118 | 119 | type val1 = { val1_x : int 120 | } 122 | type val2 = { 123 | val2_x : val1; 124 | ?val2_y : val1 option; 125 | } 126 | 127 | type base_tuple = (int * float) 128 | 132 | type extended_tuple = 133 | (int 134 | * float 135 | * : bool 136 | * : int option 137 | * string 138 | * : string list) 139 | 140 | type option_validation = 141 | int 142 | option 143 | 144 | type ('x, 'y) poly = { 145 | fst : 'x list; 146 | snd : ('x, 'y) poly option; 147 | } 148 | 149 | 150 | (* 151 | type field_hash_clash = { 152 | workshop1 : bool; 153 | examples3 : bool; 154 | } 155 | 156 | type variant_hash_clash = [ X_workshop1 | X_examples3 ] 157 | *) 158 | 159 | type int_assoc_list = 160 | (string * int) list 161 | 162 | type int_assoc_array = 163 | (string * int) list 164 | 165 | type 'a abs1 = 'a list 166 | type 'a abs2 = 'a list 167 | type 'a abs3 = 'a list 168 | 169 | type intopt = int option 170 | 171 | type int8 = int 172 | type char = int 173 | type int32 = int 174 | type int64 = int 175 | type 'a array = 'a list 176 | 177 | type id = string wrap 178 | failwith \"empty\" 184 | | _ -> None"> 185 | 186 | type json_map = (id * int) list 187 | 188 | type natural = int wrap 189 | type even_natural = natural wrap 190 | 191 | type some_record = { 192 | some_field : int 193 | } 194 | type no_real_wrap = some_record wrap 195 | 196 | type unixtime_list = float list 197 | 198 | type precision = { 199 | sqrt2_5 : float ; 200 | small_2 : float ; 201 | large_2 : float ; 202 | } 203 | 204 | type 'a generic = { x294623: int; } 205 | type specialized = string generic 206 | 207 | type validate_me = 208 | string 209 | 210 | list 211 | 212 | -------------------------------------------------------------------------------- /test/test2.atd: -------------------------------------------------------------------------------- 1 | type ('aa, 'bb) poly 2 | = abstract 3 | 4 | type poly_int2 = (int, int) poly 5 | type poly_int_string = (int, string) poly 6 | 7 | type test2 = { 8 | test0 : poly_int2; 9 | test1 : (int, string option) poly 10 | } 11 | -------------------------------------------------------------------------------- /test/test3j.atd: -------------------------------------------------------------------------------- 1 | (* JSON support only *) 2 | 3 | type json = abstract 4 | type dyn = abstract 5 | 6 | type t = { 7 | foo: int; 8 | bar: json; 9 | baz: dyn 10 | } 11 | 12 | type unixtime_list = int list 13 | 14 | 15 | (*** JSON records using one field to indicate the type of other fields ***) 16 | 17 | (* 18 | Support for the following JSON records: 19 | { "type": "integer", data: 123 } -> { data = `Integer 123 } 20 | { "type": "string", data: "abc" } -> { data = `String "abc" } 21 | *) 22 | type simple = { 23 | data : integer_or_string; 24 | (* JSON object has one extra field "type" that must 25 | contain the constructor for the OCaml variant. 26 | 27 | integer_or_string is a variant type, broken into 2 fields in the 28 | JSON representation. 29 | *) 30 | } 31 | 32 | type integer_or_string = [ 33 | | Integer of int 34 | | String of string 35 | ] 36 | 37 | 38 | (* More complex cases *) 39 | 40 | type tag = [ 41 | | A 42 | | B 43 | | C 44 | ] 45 | 46 | type constr = [ 47 | | A 48 | | B of int 49 | | C of string 50 | ] 51 | 52 | type inter_constr = [ 53 | | A of constr 54 | | B of constr 55 | | C of constr 56 | ] 57 | 58 | type constr_record = { 59 | int_field : int; 60 | tag_field : string; 61 | constr_field : constr; 62 | string_field : string; 63 | } 64 | 65 | type implicit_constr_record = { 66 | implicit_constr_field1 : constr; 67 | implicit_constr_field2 : constr; 68 | } 69 | 70 | type tag_record = { 71 | tag : tag; 72 | constr : constr; 73 | } 74 | 75 | type multi_constr_record = { 76 | multi_tag : tag; 77 | first_constr : constr; 78 | second_constr : inter_constr; 79 | } 80 | 81 | type default_tag_record = { 82 | ~default_tag : tag; 83 | default_tag_constr : constr; 84 | } 85 | 86 | type default_constr_record = { 87 | default_constr_tag : tag; 88 | ~default_constr 89 | 90 | : constr; 91 | } 92 | 93 | type default_record = { 94 | ~default2_tag : tag; 95 | ~default2_tag_constr 96 | 97 | : constr; 98 | } 99 | 100 | type default_implicit = { 101 | ~def_imp_constr : constr; 102 | } 103 | 104 | type chained_constr_record = { 105 | first_tag : tag; 106 | second_tag : inter_constr; 107 | chained_constr : constr; 108 | } 109 | 110 | type fallback_constr = [ 111 | | A 112 | | Other of (string * json option) 113 | ] 114 | 115 | type fallback_constr_record = { 116 | ~tag : string; 117 | fallback_constr : fallback_constr; 118 | } 119 | 120 | type empty_constr = [ 121 | | A 122 | | Other of (string * json option) 123 | ] 124 | 125 | type empty_constr_record = { 126 | empty : empty_constr; 127 | empty_constr : empty_constr; 128 | } 129 | -------------------------------------------------------------------------------- /test/test4.atd: -------------------------------------------------------------------------------- 1 | 2 | type 'x abs1 = abstract 3 | 4 | type 'x abs2 5 | = abstract 6 | 7 | type 'x abs3 8 | = abstract 9 | -------------------------------------------------------------------------------- /test/test5.atd: -------------------------------------------------------------------------------- 1 | (* Basic testing of -allow-name-overlap *) 2 | 3 | type ab1 = { 4 | a : string; 5 | b : int; 6 | } 7 | 8 | type ab2 = { 9 | a : string; 10 | b : int; 11 | } 12 | 13 | type bca = { 14 | b : ab2 list; 15 | c : int list; 16 | a : float; 17 | } 18 | 19 | type cd1 = [ 20 | | C of int 21 | | D of string 22 | ] 23 | 24 | type cd2 = [ 25 | | C of float 26 | | D of bool 27 | ] 28 | 29 | type cde = [ 30 | | C of int 31 | | D of cd1 32 | | E of cd2 33 | ] 34 | 35 | type all = { 36 | a : ab1; 37 | b : ab2; 38 | c : bca list; 39 | d : cde list; 40 | } 41 | 42 | type contains_variant = { 43 | foo : string; 44 | bar : [ One | Two | Three of int ] 45 | } 46 | -------------------------------------------------------------------------------- /test/test_atdgen_type_conv.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | let my_record = Test_type_conv_t.({ fst=123; snd="testing" }) 4 | 5 | let cmrs : (float Test_type_conv_t.contains_my_record) list = 6 | let open Test_type_conv_t in 7 | [ `C1 123 8 | ; `C2 123.0 9 | ; `C3 my_record ] 10 | 11 | let sexps = 12 | [my_record |> Test_type_conv_t.sexp_of_my_record] @ 13 | (List.map (Test_type_conv_t.sexp_of_contains_my_record sexp_of_float) cmrs) 14 | 15 | let () = 16 | sexps 17 | |> sexp_of_list (fun x -> x) 18 | |> Sexplib.Sexp.to_string 19 | |> print_endline 20 | -------------------------------------------------------------------------------- /test/test_lib.ml: -------------------------------------------------------------------------------- 1 | type t = Foo of int 2 | 3 | let fail _ = failwith "not implemented" 4 | 5 | module Biniou = 6 | struct 7 | type def = t 8 | let def_tag = 0 9 | let write_untagged_def _ : 'a -> unit = fail 10 | let write_def _ : 'a -> unit = fail 11 | let string_of_def = fail 12 | let get_def_reader _ = fail 13 | let read_def = fail 14 | let def_of_string = fail 15 | end 16 | 17 | module Json = 18 | struct 19 | type def = t 20 | let write_def _ : 'a -> unit = fail 21 | let string_of_def = fail 22 | let read_def _ = fail 23 | let def_of_string = fail 24 | end 25 | 26 | module Natural : 27 | sig 28 | type t = private int 29 | val wrap : int -> t 30 | val unwrap : t -> int 31 | end = 32 | struct 33 | type t = int 34 | let wrap x = 35 | if x < 0 then 36 | failwith ("Out of bounds number " ^ string_of_int x) 37 | else 38 | x 39 | let unwrap x = x 40 | end 41 | 42 | module Even_natural : 43 | sig 44 | type t = private Natural.t 45 | val wrap : Natural.t -> t 46 | val unwrap : t -> Natural.t 47 | end = 48 | struct 49 | type t = Natural.t 50 | let wrap (x : Natural.t) = 51 | if (x :> int) mod 2 <> 0 then 52 | failwith ("Odd number " ^ string_of_int (x :> int)) 53 | else 54 | x 55 | let unwrap x = x 56 | end 57 | -------------------------------------------------------------------------------- /test/test_type_conv.atd: -------------------------------------------------------------------------------- 1 | 2 | 3 | type my_record = { 4 | fst: int; 5 | snd: string; 6 | } 7 | 8 | 9 | type 'a contains_my_record = [ 10 | | C1 of int 11 | | C2 of 'a 12 | | C3 of my_record 13 | ] 14 | -------------------------------------------------------------------------------- /util/recompile-deps: -------------------------------------------------------------------------------- 1 | # -*- sh -*- 2 | # Script for working with development versions of atdgen's dependencies. 3 | # All git repositories (atd, atdgen, etc.) must exist in the same directory. 4 | 5 | # Usage (from within atdgen/): . util/recompile-deps 6 | 7 | # This script is meant to be sourced from the atdgen directory. 8 | # It sets the OCAMLPATH variable such that the development versions 9 | # of atdgen's dependencies are found first when compiling. 10 | 11 | atdgen_dir=$(pwd) 12 | parent=$atdgen_dir/.. 13 | export OCAMLPATH=$parent 14 | for x in cppo easy-format atd biniou yojson atdgen; do 15 | (cd parent/$x; make clean; make) 16 | done 17 | --------------------------------------------------------------------------------