pax_global_header00006660000000000000000000000064127312033400014505gustar00rootroot0000000000000052 comment=decacd66745a969d872e94e2d62ce3d1c722bce7 atdgen-1.9.1/000077500000000000000000000000001273120334000127575ustar00rootroot00000000000000atdgen-1.9.1/.gitignore000066400000000000000000000001131273120334000147420ustar00rootroot00000000000000*~ *.cmi *.cmo *.cmx *.cma *.cmxa *.cmxs *.a *.o *.annot *.run *.opt *.exe atdgen-1.9.1/.merlin000066400000000000000000000000361273120334000142450ustar00rootroot00000000000000PKG yojson atd B ./** S ./** atdgen-1.9.1/.ocp-indent000066400000000000000000000015721273120334000150250ustar00rootroot00000000000000# See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more # Indent for clauses inside a pattern-match (after the arrow): # match foo with # | _ -> # ^^^^bar # the default is 2, which aligns the pattern and the expression match_clause = 4 # When nesting expressions on the same line, their indentation are in # some cases stacked, so that it remains correct if you close them one # at a line. This may lead to large indents in complex code though, so # this parameter can be used to set a maximum value. Note that it only # affects indentation after function arrows and opening parens at end # of line. # # for example (left: `none`; right: `4`) # let f = g (h (i (fun x -> # let f = g (h (i (fun x -> # x) # x) # ) # ) # ) # ) max_indent = 2 atdgen-1.9.1/INSTALL000066400000000000000000000041231273120334000140100ustar00rootroot00000000000000 Installation instructions for atdgen ==================================== Godi makes the installation process straightforward. Simply install the godi-atdgen package using `godi_console'. Dependencies will be selected and installed automatically. Requirements ------------ - Objective Caml (>= 3.11 is fine, earlier versions are probably fine too) - GNU make - Findlib (`ocamlfind' command): http://www.camlcity.org/archive/programming/findlib.html - menhir (installation of atd): http://pauillac.inria.fr/~fpottier/menhir/ - easy-format (required for biniou, yojson and atd): http://martin.jambon.free.fr/easy-format.html - cppo (installation of yojson only): http://martin.jambon.free.fr/cppo.html - biniou (>= 1.0.0): http://martin.jambon.free.fr/biniou.html - yojson (>= 1.0.0): http://martin.jambon.free.fr/yojson.html - atd (>= 1.0.0): http://oss.wink.com/atd/ Manual installation ------------------- make # or `make all' for the bytecode-only version make install # or `make BINDIR=/foo/bin install' for installing executables # in a place other than the guessed default. Manual uninstallation --------------------- make uninstall Getting started --------------- First take a look at the example in the `example' subdirectory. Commands installed by the different packages: - atdgen: produces OCaml code from ATD type definitions - atdcat: pretty-prints ATD type definitions - bdump: displays biniou data in human-readable form - ydump: pretty-prints JSON data Sources of documentation: - command-line interface help: `atdgen -help' - type definition syntax: atd manual - options available for each language (ocaml, biniou, json, doc): atdgen manual - generic biniou tree: biniou documentation, module Bi_io - generic JSON tree: yojson documentation, module Yojson.Safe - biniou input buffers: biniou documentation, module Bi_inbuf - output buffers: biniou documentation, module Bi_outbuf Contact ------- Bugs and feedback should be sent to Martin Jambon or . atdgen-1.9.1/LICENSE000066400000000000000000000025511273120334000137670ustar00rootroot00000000000000Copyright (c) 2010 MyLife All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. atdgen-1.9.1/META000066400000000000000000000005171273120334000134330ustar00rootroot00000000000000# This META file is used during testing only. # The META file that we install is src/META (generated from src/META.in) description = "Development version of atdgen - not installed" requires = "str atd biniou yojson" directory = "src" archive(byte) = "atdgen.cma" archive(native) = "atdgen.cmxa" archive(native,plugin) = "atdgen.cmxs" atdgen-1.9.1/Makefile000066400000000000000000000017771273120334000144330ustar00rootroot00000000000000ifndef PREFIX PREFIX = $(shell dirname $$(dirname $$(which ocamlfind))) export PREFIX endif ifndef BINDIR BINDIR = $(PREFIX)/bin export BINDIR endif .PHONY: default test all opt install uninstall reinstall clean default: $(MAKE) -C src all: $(MAKE) -C src all opt: $(MAKE) -C src opt .PHONY: findlib-install findlib-uninstall findlib-install: $(MAKE) -C src findlib-install findlib-uninstall: $(MAKE) -C src findlib-uninstall .PHONY: exe-install exe-uninstall exe-install: $(MAKE) -C src exe-install $(MAKE) -C atdgen-cppo exe-install exe-uninstall: $(MAKE) -C src exe-uninstall $(MAKE) -C atdgen-cppo exe-uninstall install: $(MAKE) -C src install $(MAKE) -C atdgen-cppo install uninstall: $(MAKE) -C src uninstall $(MAKE) -C atdgen-cppo uninstall reinstall: $(MAKE) -C src reinstall $(MAKE) -C atdgen-cppo reinstall test: $(MAKE) -C test test-all: $(MAKE) -C test test-all clean: rm -f *~ util/*~ example/*~ $(MAKE) -C src clean $(MAKE) -C test clean $(MAKE) -C atdgen-cppo clean atdgen-1.9.1/README.md000066400000000000000000000006031273120334000142350ustar00rootroot00000000000000Atdgen uses type definitions in the ATD syntax and generates efficient [JSON](http://json.org) serializers, deserializers and validators for OCaml. Installation ------------ ``` $ opam install atdgen ``` Documentation ------------- https://mjambon.github.io/atdgen-doc/ How to contribute ----------------- See https://github.com/mjambon/documents/blob/master/how-to-contribute.md atdgen-1.9.1/TODO.md000066400000000000000000000020341273120334000140450ustar00rootroot00000000000000* Support JSON object syntax for variants, e.g.: type t = A | B of int Currently supported: "A" ["B", 123] <"A"> <"B":123> To do: {"A": null} {"B": 123} * Find a good way to support variants represented as records whose type is given by one of their fields. * Plans for atdgen 2: - create one (sub)command for each target language (atdgen-ocaml, atdgen-java, atdgen-atd, atdgen-ts) - imply -std-json, i.e. do not produce code that produces JSON in the extended syntax for variants (<"A">, <"B":123>) or tuples (("a", 123, {"x":0})) - make it possible to produce all outputs in one call to atdgen. "atdgen foo -m tjv" would read file "foo.atd" and produce files foo_{t|j|v}.{ml|mli} - use classic variants instead of polymorphic variants by default since ocaml >= 4.01 makes them easier to use * Support for other languages: - merge atdj (JSON serializers for Java) into atdgen - translate ATD into TypeScript type definitions atdgen-1.9.1/atdgen-cppo/000077500000000000000000000000001273120334000151605ustar00rootroot00000000000000atdgen-1.9.1/atdgen-cppo/LICENSE000066400000000000000000000025651273120334000161750ustar00rootroot00000000000000Copyright (c) 2011-2012 Martin Jambon All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the author may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. atdgen-1.9.1/atdgen-cppo/Makefile000066400000000000000000000013051273120334000166170ustar00rootroot00000000000000ifndef PREFIX PREFIX = $(shell dirname $$(dirname $$(which ocamlfind))) export PREFIX endif ifndef BINDIR BINDIR = $(PREFIX)/bin export BINDIR endif .PHONY: default demo clean install uninstall reinstall .PHONY: exe-install exe-uninstall default: demo demo: @echo "--- Demo ---" ocamlfind opt -o example \ -pp cppo-json \ -package atdgen -linkpkg \ example.ml ./example exe-install: cp atdgen-cppo cppo-json "$(BINDIR)" exe-uninstall: rm -f "$(BINDIR)"/atdgen-cppo "$(BINDIR)"/cppo-json install: exe-install uninstall: exe-uninstall reinstall: $(MAKE) uninstall BINDIR="$(BINDIR)" $(MAKE) install BINDIR="$(BINDIR)" clean: rm -f *.cm[iox] *.o *~ example atdgen-1.9.1/atdgen-cppo/README.md000066400000000000000000000030271273120334000164410ustar00rootroot00000000000000`cppo-json` is a preprocessor that replaces embedded type definition directives with OCaml type definitions and JSON serialization/deserialization code. `atdgen-cppo` is the script that reads type definitions from stdin and generates OCaml code. It takes options allowing users to pick what kind of code needs to be generated (type definitions, JSON serialization, Biniou serialization, validators). Example ------- Sample input: ``` $ cat example.ml #ext json type mytype = string list #endext let data = [ "Hello"; "world" ] let () = print_endline (J.string_of_mytype data) ``` How to view the OCaml code produced by cppo-json: ``` $ cppo-json < example.ml | less ``` How to compile an OCaml program: ``` $ ocamlfind opt -o example \ -pp cppo-json \ -package atdgen -linkpkg \ example.ml ``` cppo-json ships with atdgen-cppo and is shorthand for the following command: ``` cppo -x "json:atdgen-cppo t j v" ``` where `t` stands for "type definitions", `j` stands for "JSON", and `v` stands for "validators". See also: ``` $ cppo-json --help $ atdgen-cppo --help $ cppo --help ``` Documentation ------------- Documentation is provided by the `--help` option of each command. Direct dependencies ------------------- * [atdgen](https://github.com/MyLifeLabs/atdgen) * [cppo](https://github.com/mjambon/cppo) Installation ------------ It's just two shell scripts. You can copy them by hand to the directory of your choice or run: ``` $ make install # installs into $HOME/bin ``` or ``` $ BINDIR=/path/to/bin make install ``` atdgen-1.9.1/atdgen-cppo/atdgen-cppo000077500000000000000000000031341273120334000173100ustar00rootroot00000000000000#! /bin/sh -e version=1.0.0 self="$0" usage () { echo "\ Usage: $self [t] [b] [j] [v] atdgen-cppo makes it possible to use atdgen to derive code from ATD type definitions embedded in OCaml source files rather than in separate .atd files. This is similar to how json-static is used, except that the preprocessor is not camlp4 but the simpler program cppo. Modes: t produce a module T containing OCaml type definitions translated from ATD b produce a module B containing OCaml code for biniou serialization j produce a module J containing OCaml code JSON serialization v produce a module V containing OCaml code for validation Typical usage: \$ cat example.ml #ext json type mytype = string list #endext let data = [ \"Hello\"; \"world\" ] let () = print_endline (J.string_of_mytype data) \$ ocamlfind opt -o example \\ -pp 'cppo -x \"json:$self t j\"' \\ -package atdgen -linkpkg example.ml \$ ./example [\"Hello\",\"world\"] " >&2 } case "$1" in -h|-help|--help) usage; exit 0 ;; *) ;; esac tmp=$(tempfile -p ml- -s -atdgen-cppo.ml) cat > $tmp fail () { rm -f $tmp exit 1 } # CPPO_FIRST_LINE is off by one in cppo 0.9.1. # Should be fixed in cppo rather than here. gen () { echo "module $1 = (" atdgen \ -pos-fname "$CPPO_FILE" \ -pos-lnum $(( $CPPO_FIRST_LINE + 1 )) \ -$2 < $tmp || fail echo ")" } while [ $# != 0 ]; do case "$1" in t) gen T t ;; b) gen B b ;; j) gen J j ;; v) gen V v ;; --help|-help) usage; exit 0 ;; *) usage; exit 2 esac shift done rm -f $tmp atdgen-1.9.1/atdgen-cppo/cppo-json000077500000000000000000000021161273120334000170160ustar00rootroot00000000000000#! /bin/sh usage () { echo "\ Usage: cppo-json [cppo arguments] cppo-json processes an OCaml file written with embedded type definitions directives and replaces them by OCaml type definitions and JSON serialization/deserialization code. Sample input: \$ cat example.ml #ext json type mytype = string list #endext let data = [ \"Hello\"; \"world\" ] let () = print_endline (J.string_of_mytype data) How to view the OCaml code produced by cppo-json: \$ cppo-json < example.ml | less How to compile an OCaml program: \$ ocamlfind opt -o example \\ -pp cppo-json \\ -package atdgen -linkpkg \\ example.ml cppo-json ships with atdgen-cppo and is shorthand for the following command: cppo -x \"json:atdgen-cppo t j v\" where 't' stands for 'type definitions', 'j' stands for 'JSON', and 'v' stands for \"validators\". See also: atdgen-cppo --help cppo --help " >&2 } case "$1" in --help|-help) usage; exit 0 ;; *) esac cppo -x "json:atdgen-cppo t j v" "$@" case $? in 0) ;; *) echo "cppo-json failed" >&2 exit 2 esac atdgen-1.9.1/atdgen-cppo/example.ml000066400000000000000000000001751273120334000171500ustar00rootroot00000000000000#ext json type mytype = string list #endext let data = [ "Hello"; "world" ] let () = print_endline (J.string_of_mytype data) atdgen-1.9.1/atdgen.install000066400000000000000000000001731273120334000156120ustar00rootroot00000000000000bin: [ "src/atdgen.run" {"atdgen.run"} "src/atdgen" {"atdgen"} "atdgen-cppo/atdgen-cppo" "atdgen-cppo/cppo-json" ] atdgen-1.9.1/example/000077500000000000000000000000001273120334000144125ustar00rootroot00000000000000atdgen-1.9.1/example/Makefile000066400000000000000000000003321273120334000160500ustar00rootroot00000000000000.PHONY: default default: ./example.sh .PHONY: clean rm -f *.cm[iox] *.o *.annot \ format_v[12].mli format_v[12].ml \ upgrade_demo upgrade_demo.exe \ old_sample.dat new_sample.dat \ old_data.dat new_data.dat atdgen-1.9.1/example/README000066400000000000000000000012451273120334000152740ustar00rootroot00000000000000 Example using atdgen ==================== This simple but standalone example illustrates the use of atdgen to manage a backward-compatible change of data format. The old data format is defined in `format_v1.atd'. The newer data format is defined in `format_v2.atd'. It is a record type from which one field was removed and another field was added. The program `upgrade_demo' demonstrates the use of atdgen in general and how to make a data format evolve without losing compatibility with legacy data files or services. 1. Atdgen must be installed properly 2. Run `make' 3. Inspect the files starting with example.sh atdgen-1.9.1/example/example.sh000066400000000000000000000023031273120334000163770ustar00rootroot00000000000000#! /bin/sh echo "Running script $0, look inside for comments." # Exit on error set -e # Produce format_v1.mli and format_v1.ml from type definition atdgen format_v1.atd # Produce format_v2.mli and format_v2.ml from type definition atdgen format_v2.atd # Compile and link all OCaml code, producing upgrade_demo ocamlfind ocamlopt -g -dtypes -package atdgen -linkpkg \ format_v1.mli format_v1.ml \ format_v2.mli format_v2.ml \ upgrade_demo.ml -o upgrade_demo # Save biniou sample in the old format ./upgrade_demo old > old_sample.dat # Save the same data after conversion to the new format ./upgrade_demo new > new_sample.dat # Use our sample data in the old format for the next test cp old_sample.dat old_data.dat # Read data in the old format with code assuming the new format ./upgrade_demo up < old_data.dat > new_data.dat # Dump a text representation of old and new data. # The -w option specifies a list of candidate field names required for # converting hashed field names into the original names. echo "Data in format v1:" bdump old_data.dat -w a,b,c,d echo "Converted to format v2:" bdump new_data.dat -w a,c,d,e echo "Same, displayed using incomplete name dictionary:" bdump new_data.dat -w a,b atdgen-1.9.1/example/format_v1.atd000066400000000000000000000001741273120334000170040ustar00rootroot00000000000000(* Older version of an imagined data format *) type t = { a : int option; b : bool; ?c : int option; ~d : float; } atdgen-1.9.1/example/format_v2.atd000066400000000000000000000005531273120334000170060ustar00rootroot00000000000000(* Newer version of an imagined data format. Compare to `format_v1.atd'. *) type t = { a : int option; (* removed field b, making newer data unreadable with older software since b was not optional. *) ?c : int option; ~d : float; ~e : string list; (* added optional field e, allowing newer software to read older data. *) } atdgen-1.9.1/example/upgrade_demo.ml000066400000000000000000000024021273120334000173750ustar00rootroot00000000000000open Printf let old_data = { Format_v1.a = Some 1; b = true; c = Some 3; d = 4.0; } let print_old_data () = let ob = Bi_outbuf.create_channel_writer stdout in Format_v1.write_t ob old_data; Bi_outbuf.flush_channel_writer ob; flush stdout let convert x = Format_v2.t_of_string (Format_v1.string_of_t ~len:100 x) let print_new_data () = let new_data = convert old_data in let ob = Bi_outbuf.create_channel_writer stdout in Format_v2.write_t ob new_data; Bi_outbuf.flush_channel_writer ob; flush stdout let upgrade () = let ib = Bi_inbuf.from_channel stdin in let x = Format_v2.read_t ib in let ob = Bi_outbuf.create_channel_writer stdout in Format_v2.write_t ob x; Bi_outbuf.flush_channel_writer ob; flush stdout let usage () = eprintf "\ Usage: %s [old|new|up] old print sample data in the old format new print sample data in the new format up read data in the new format from stdin and print data in the new format %!" Sys.argv.(0); exit 1 let main () = match Sys.argv with [| _; action |] -> (match action with "old" -> print_old_data () | "new" -> print_new_data () | "up" -> upgrade () | _ -> usage () ) | _ -> usage () let () = main () atdgen-1.9.1/opam000066400000000000000000000007331273120334000136410ustar00rootroot00000000000000opam-version: "1.2" maintainer: "martin@mjambon.com" authors: ["Martin Jambon"] homepage: "https://github.com/mjambon/atdgen" bug-reports: "https://github.com/mjambon/atdgen/issues" dev-repo: "https://github.com/mjambon/atdgen.git" build: [ [make] ] install: [make "findlib-install"] build-test: [ [make] [make "test"] ] remove: [ ["ocamlfind" "remove" "atdgen"] ] depends: [ "ocamlfind" "atd" {>= "1.1.0"} "biniou" {>= "1.0.6"} "yojson" {>= "1.2.1" } ] atdgen-1.9.1/src/000077500000000000000000000000001273120334000135465ustar00rootroot00000000000000atdgen-1.9.1/src/.gitignore000066400000000000000000000006751273120334000155460ustar00rootroot00000000000000META VERSION ag_version.ml test.ml test.mli test2.ml test2.mli test2j.ml test2j.mli test3b.ml test3b.mli test3j.ml test3j.mli test4.ml test4.mli test4j.ml test4j.mli test5_b.ml test5_b.mli test5_j.ml test5_j.mli test5_t.ml test5_t.mli testj.ml testj.mli testjstd.ml testjstd.mli testv.ml testv.mli test-2.bin test-2.json test-json-files.json test-json-streams.json test-std.json test.bin test.json test_atdgen testdoc ag_doc_lexer.ml atdgen dep atdgen-1.9.1/src/META.in000066400000000000000000000003121273120334000146200ustar00rootroot00000000000000description = "Code generators using ATD as specification language" requires = "str atd biniou yojson" archive(byte) = "atdgen.cma" archive(native) = "atdgen.cmxa" archive(native,plugin) = "atdgen.cmxs"atdgen-1.9.1/src/Makefile000066400000000000000000000105321273120334000152070ustar00rootroot00000000000000VERSION = 1.9.1 ifeq "$(shell ocamlc -config |grep os_type)" "os_type: Win32" EXE=.exe else EXE= endif NATDYNLINK := $(shell if [ -f `ocamlc -where`/dynlink.cmxa ]; then \ echo YES; \ else \ echo NO; \ fi) ifeq "${NATDYNLINK}" "YES" CMXS=atdgen.cmxs endif # Shared stuff SOURCES_SHARED = \ ag_version.ml \ ag_error.ml \ ag_mapping.ml \ ag_doc_lexer.mll \ ag_doc.mli ag_doc.ml \ ag_ocaml.ml \ ag_indent.ml \ ag_ox_emit.ml # Biniou/OCaml SOURCES_BINIOU = \ ag_biniou.ml \ ag_xb_emit.ml \ ag_ob_mapping.ml \ ag_ob_spe.ml \ ag_ob_emit.ml # JSON/OCaml SOURCES_JSON = \ ag_string_match.mli ag_string_match.ml \ ag_json.ml \ ag_oj_mapping.ml \ ag_oj_emit.ml # OCaml validators SOURCES_VALIDATE = \ ag_validate.ml \ ag_ov_mapping.ml \ ag_ov_emit.ml # OCaml runtime library SOURCES_RUNTIME = \ ag_ob_run.ml \ ag_oj_run.ml \ ag_ov_run.ml \ ag_util.mli ag_util.ml SOURCES = \ $(SOURCES_SHARED) $(SOURCES_BINIOU) $(SOURCES_JSON) $(SOURCES_VALIDATE) \ $(SOURCES_RUNTIME) DOCFILES = ag_doc ag_util DOCSOURCES = $(addsuffix .mli, $(DOCFILES)) MLY = $(filter %.mly, $(SOURCES)) MLL = $(filter %.mll, $(SOURCES)) OCAMLLEX_ML = $(patsubst %.mll,%.ml, $(MLL)) OCAMLYACC_MLI = $(patsubst %.mly,%.mli, $(MLY)) OCAMLYACC_ML = $(patsubst %.mly,%.ml, $(MLY)) MLSOURCES = $(patsubst %.mll,%.ml, $(patsubst %.mly,%.ml, $(SOURCES))) MLI = $(filter %.mli, $(MLSOURCES)) ML = $(filter %.ml, $(MLSOURCES)) CMI = $(patsubst %.ml,%.cmi, $(ML)) CMO = $(patsubst %.ml,%.cmo, $(ML)) CMX = $(patsubst %.ml,%.cmx, $(ML)) O = $(patsubst %.ml,%.o, $(ML)) OCAMLFLAGS = -dtypes -g OCAMLPACKS = str atd biniou yojson ifndef PREFIX PREFIX = $(shell dirname $$(dirname $$(which ocamlfind))) export PREFIX endif ifndef BINDIR BINDIR = $(PREFIX)/bin export BINDIR endif .PHONY: default default: all opt .PHONY: pp pp: VERSION META $(OCAMLLEX_ML) $(OCAMLYACC_MLI) $(OCAMLYACC_ML) $(MAKE) dep .PHONY: all opt all: pp $(MAKE) atdgen.cma atdgen.run opt: pp $(MAKE) atdgen.cmxa $(CMXS) atdgen$(EXE) .PHONY: exe-install exe-uninstall exe-install: test ! -f atdgen.run || cp atdgen.run $(BINDIR)/ test ! -f atdgen.run.exe || cp atdgen.run.exe $(BINDIR)/ test ! -f atdgen || cp atdgen $(BINDIR)/ test ! -f atdgen.exe || cp atdgen.exe $(BINDIR)/ exe-uninstall: test ! -f $(BINDIR)/atdgen.run || rm $(BINDIR)/atdgen.run test ! -f $(BINDIR)/atdgen.run.exe || rm $(BINDIR)/atdgen.run.exe test ! -f $(BINDIR)/atdgen || rm $(BINDIR)/atdgen test ! -f $(BINDIR)/atdgen.exe || rm $(BINDIR)/atdgen.exe .PHONY: findlib-install findlib-uninstall findlib-uninstall: ocamlfind remove atdgen findlib-install: META ocamlfind install atdgen META \ $(MLI) $(CMI) $(CMO) $(CMX) $(CMXS) $(O) \ atdgen.cma atdgen.a atdgen.cmxa .PHONY: install uninstall reinstall uninstall: findlib-uninstall exe-uninstall install: findlib-install exe-install reinstall: $(MAKE) uninstall || : $(MAKE) install ag_version.ml: Makefile echo 'let version = "$(VERSION)"' > ag_version.ml META: META.in Makefile echo 'version = "$(VERSION)"' > META cat META.in >> META VERSION: Makefile echo $(VERSION) > VERSION %.cmi: %.mli ocamlfind ocamlc $(OCAMLFLAGS) -c -package "$(OCAMLPACKS)" $< %.cmi: %.ml ocamlfind ocamlc $(OCAMLFLAGS) -c -package "$(OCAMLPACKS)" $< %.cmo: %.ml ocamlfind ocamlc $(OCAMLFLAGS) -c -package "$(OCAMLPACKS)" $< %.cmx: %.ml ocamlfind ocamlopt $(OCAMLFLAGS) -c -package "$(OCAMLPACKS)" $< ag_doc_lexer.ml: ag_doc_lexer.mll ocamllex $< dep: $(SOURCES) Makefile ocamlfind ocamldep -package "$(OCAMLPACKS)" $(MLI) $(ML) > dep ifneq ($(MAKECMDGOALS),clean) -include dep endif atdgen.cma: dep $(CMI) $(CMO) ocamlfind ocamlc $(OCAMLFLAGS) -o atdgen.cma -a $(CMO) atdgen.cmxa: dep $(CMI) $(CMX) ocamlfind ocamlopt $(OCAMLFLAGS) -o atdgen.cmxa -a $(CMX) atdgen.cmxs: dep $(CMI) $(CMX) ocamlfind ocamlopt $(OCAMLFLAGS) -shared -o $(CMXS) $(CMX) atdgen.run: dep $(CMI) $(CMO) ag_main.ml ocamlfind ocamlc $(OCAMLFLAGS) -o atdgen.run \ -package "$(OCAMLPACKS)" -linkpkg \ $(CMO) ag_main.ml atdgen$(EXE): dep $(CMI) $(CMX) ag_main.ml ocamlfind ocamlopt $(OCAMLFLAGS) -o atdgen$(EXE) \ -package "$(OCAMLPACKS)" -linkpkg \ $(CMX) ag_main.ml .PHONY: clean clean: rm -f *.o *.a *.cm* *~ *.annot \ dep atdgen atdgen.exe atdgen.run \ ag_doc_lexer.ml ag_version.ml META VERSION atdgen-1.9.1/src/ag_biniou.ml000066400000000000000000000025741273120334000160440ustar00rootroot00000000000000(* Mapping from ATD to biniou *) type biniou_int = [ `Svint | `Uvint | `Int8 | `Int16 | `Int32 | `Int64 ] type biniou_float = [ `Float32 | `Float64 ] type biniou_list = [ `Array | `Table ] type biniou_field = { biniou_unwrapped : bool } type biniou_repr = [ | `Unit | `Bool | `Int of biniou_int | `Float of biniou_float | `String | `Sum | `Record | `Tuple | `List of biniou_list | `Option | `Nullable | `Wrap | `External | `Cell | `Field of biniou_field | `Variant | `Def ] let biniou_int_of_string s : biniou_int option = match s with "svint" -> Some `Svint | "uvint" -> Some `Uvint | "int8" -> Some `Int8 | "int16" -> Some `Int16 | "int32" -> Some `Int32 | "int64" -> Some `Int64 | _ -> None let biniou_float_of_string s : biniou_float option = match s with "float32" -> Some `Float32 | "float64" -> Some `Float64 | _ -> None let biniou_list_of_string s : biniou_list option = match s with "array" -> Some `Array | "table" -> Some `Table | _ -> None let get_biniou_int an = Atd_annot.get_field biniou_int_of_string `Svint ["biniou"] "repr" an let get_biniou_float an = Atd_annot.get_field biniou_float_of_string `Float64 ["biniou"] "repr" an let get_biniou_list an = Atd_annot.get_field biniou_list_of_string `Array ["biniou"] "repr" an atdgen-1.9.1/src/ag_doc.ml000066400000000000000000000007641273120334000153230ustar00rootroot00000000000000 type inline = [ `Text of string | `Code of string ] type block = [ `Paragraph of inline list | `Pre of string ] type doc = [ `Text of block list ] let parse_text loc s = try Some (Some (`Text (Ag_doc_lexer.parse_string s : block list))) with e -> failwith (Printf.sprintf "%s:\nInvalid format for doc.text %S:\n%s" (Atd_ast.string_of_loc loc) s (Printexc.to_string e)) let get_doc loc an : doc option = Atd_annot.get_field (parse_text loc) None ["doc"] "text" an atdgen-1.9.1/src/ag_doc.mli000066400000000000000000000036501273120334000154710ustar00rootroot00000000000000 (** Support for annotations: type foo = [ Bar of int ] This allows code generators to inject the documentation into the generated code. nodes that appear in the following positions should be taken into account by code generators that care about documentation: - after the type name on the left-hand side of a type definition - after the type expression on the right-hand side of a type definition (but not after any type expression) - after record field names - after variant names Formats: Currently only one format called "text" is supported: - Blank lines separate paragraphs. - [\{\{ \}\}] can be used to enclose inline verbatim text. - [\{\{\{ \}\}\}] can be used to enclose verbatim text where whitespace is preserved. - The backslash character is used to escape special character sequences. In regular paragraph mode the special sequences are [\ ], [\{\{] and [\{\{\{]. In inline verbatim text, special sequences are [\ ] and [\}\}]. In verbatim text, special sequences are [\ ] and [\}\}\}]. Character encoding: UTF-8 is strongly recommended, if not plain ASCII. *) type inline = [ `Text of string | `Code of string ] (** [`Text] is regular text. [`Code] is text that was enclosed within [\{\{ \}\}] and should be rendered using the same fixed-width font used in all verbatim text. *) type block = [ `Paragraph of inline list | `Pre of string ] (** [`Paragraph] is a regular paragraph. [`Pre] is preformatted text that was enclosed within [\{\{\{ \}\}\}] and should be rendered using a fixed-width font preserving all space and newline characters. *) type doc = [ `Text of block list ] (** A document is a list of paragraph-like blocks. *) val get_doc : Atd_ast.loc -> Atd_ast.annot -> doc option (** Get and parse doc data from annotations. *) atdgen-1.9.1/src/ag_doc_lexer.mll000066400000000000000000000062761273120334000167020ustar00rootroot00000000000000{ let close_paragraph a1 a2 a3 = let a2 = match String.concat "" (List.rev a3) with "" -> a2 | s -> `Text s :: a2 in match List.rev a2 with [] -> a1 | l -> `Paragraph l :: a1 } let space = [' ' '\t' '\r' '\n'] let space' = space#['\n'] let par_special = ['\\' '{' '}'] let par_not_special = [^ '\\' '{' '}' ' ' '\t' '\r' '\n'] let verb_not_special = [^ '\\' ' ' '\t' '\r' '\n' '}'] (* Paragraph mode *) rule paragraph a1 a2 a3 = parse '\\' ('\\' | "{{" | "{{{" as s) { paragraph a1 a2 (s :: a3) lexbuf } | "{{" { let code = inline_verbatim [] lexbuf in let a2 = match String.concat "" (List.rev a3) with "" -> a2 | s -> `Text s :: a2 in let a2 = `Code code :: a2 in paragraph a1 a2 [] lexbuf } | space* "{{{" (("\r"?) "\n")? { let pre = verbatim [] lexbuf in let a1 = close_paragraph a1 a2 a3 in let a1 = `Pre pre :: a1 in paragraph a1 [] [] lexbuf } | par_not_special+ as s { paragraph a1 a2 (s :: a3) lexbuf } | space'* "\n"? space'* { paragraph a1 a2 (" " :: a3) lexbuf } | space'* "\n" (space'* "\n")+ space'* { let a1 = close_paragraph a1 a2 a3 in paragraph a1 [] [] lexbuf } | space* eof { let a1 = close_paragraph a1 a2 a3 in List.rev a1 } | _ as c { paragraph a1 a2 (String.make 1 c :: a3) lexbuf } (* Inline verbatim mode: Only "}}" need to be escaped. Backslashes can be escaped but single backslashes are tolerated. *) and inline_verbatim accu = parse "\\\\" { inline_verbatim ("\\" :: accu) lexbuf } | "\\}}" { inline_verbatim ("}}" :: accu) lexbuf } | space+ { inline_verbatim (" " :: accu) lexbuf } | verb_not_special+ as s { inline_verbatim (s :: accu) lexbuf } | _ as c { inline_verbatim (String.make 1 c :: accu) lexbuf } | space* "}}" { String.concat "" (List.rev accu) } | eof { failwith "Missing `}}'" } (* Verbatim paragraph mode: Only "}}}" need to be escaped. Backslashes can be escaped but single backslashes are tolerated. *) and verbatim accu = parse "\\\\" { verbatim ("\\" :: accu) lexbuf } | "\\}}}" { verbatim ("}}}" :: accu) lexbuf } | '\t' { verbatim (" " :: accu) lexbuf } | "\r\n" { verbatim ("\n" :: accu) lexbuf } | verb_not_special+ as s { verbatim (s :: accu) lexbuf } | _ as c { verbatim (String.make 1 c :: accu) lexbuf } | ('\r'? '\n')? "}}}" { String.concat "" (List.rev accu) } | eof { failwith "Missing `}}}'" } { let parse_string s = let lexbuf = Lexing.from_string s in paragraph [] [] [] lexbuf } atdgen-1.9.1/src/ag_error.ml000066400000000000000000000007701273120334000157040ustar00rootroot00000000000000 open Printf let error loc msg = failwith (sprintf "%s:\n%s" (Atd_ast.string_of_loc loc) msg) let error2 loc1 msg1 loc2 msg2 = failwith (sprintf "%s:\n%s\n%s:\n%s" (Atd_ast.string_of_loc loc1) msg1 (Atd_ast.string_of_loc loc2) msg2) let error3 loc1 msg1 loc2 msg2 loc3 msg3 = failwith (sprintf "%s:\n%s\n%s:\n%s\n%s:\n%s" (Atd_ast.string_of_loc loc1) msg1 (Atd_ast.string_of_loc loc2) msg2 (Atd_ast.string_of_loc loc3) msg3) atdgen-1.9.1/src/ag_indent.ml000066400000000000000000000010101273120334000160200ustar00rootroot00000000000000 (* Atd_indent extended with annnotations allowing some postprocessing. *) type t = [ | `Line of string (* single line (not indented) *) | `Block of t list (* indented sequence *) | `Inline of t list (* in-line sequence (not indented) *) | `Annot of (string * t) (* arbitrary annotation *) ] let rec strip : t -> Atd_indent.t = function `Line _ as x -> x | `Block l -> `Block (List.map strip l) | `Inline l -> `Inline (List.map strip l) | `Annot (_, x) -> strip x atdgen-1.9.1/src/ag_json.ml000066400000000000000000000034231273120334000155220ustar00rootroot00000000000000(* Mapping from ATD to JSON *) type json_float = [ `Float of int option (* max decimal places *) | `Int ] type json_list = [ `Array | `Object ] type json_variant = { json_cons : string } type json_field = { json_fname : string; (* *) json_tag_field : string option; (* *) json_unwrapped : bool } type json_repr = [ | `Unit | `Bool | `Int | `Float of json_float | `String | `Sum | `Record | `Tuple | `List of json_list | `Option | `Nullable | `Wrap (* should we add support for Base64 encoding of binary data? *) | `External | `Cell | `Field of json_field | `Variant of json_variant | `Def ] let json_float_of_string s : [ `Float | `Int ] option = match s with "float" -> Some `Float | "int" -> Some `Int | _ -> None let json_precision_of_string s = try Some (Some (int_of_string s)) with _ -> None let get_json_precision an = Atd_annot.get_field json_precision_of_string None ["json"] "precision" an let get_json_float an : json_float = match Atd_annot.get_field json_float_of_string `Float ["json"] "repr" an with `Float -> `Float (get_json_precision an) | `Int -> `Int let json_list_of_string s : json_list option = match s with "array" -> Some `Array | "object" -> Some `Object | _ -> None let get_json_list an = Atd_annot.get_field json_list_of_string `Array ["json"] "repr" an let get_json_cons default an = Atd_annot.get_field (fun s -> Some s) default ["json"] "name" an let get_json_fname default an = Atd_annot.get_field (fun s -> Some s) default ["json"] "name" an let get_json_tag_field an = Atd_annot.get_field (fun s -> Some (Some s)) None ["json"] "tag_field" an atdgen-1.9.1/src/ag_main.ml000066400000000000000000000344741273120334000155070ustar00rootroot00000000000000 open Printf let append l1 l2 = List.flatten (List.map (fun s1 -> List.map (fun s2 -> s1 ^ s2) l2) l1) let get_file_list base = append (append [base] ["_t";"_b";"_j";"_v"]) [".mli";".ml"] let print_file_list base = let l = get_file_list base in print_endline (String.concat " " l) let print_deps base = let l = get_file_list base in List.iter (fun out -> printf "%s: %s.atd\n" out base) l; flush stdout let set_once varname var x = match !var with Some y -> if x <> y then failwith (sprintf "\ Command-line parameter %S is set multiple times to incompatible values." varname) | None -> var := Some x type mode = [ `T (* -t (type defs and create_* functions) *) | `B (* -b (biniou serialization) *) | `J (* -j (json serialization) *) | `V (* -v (validators) *) | `Dep (* -dep (print all file dependencies produced by -t -b -j -v) *) | `List (* -list (list all files produced by -t -b -j -v) *) | `Biniou (* -biniou (deprecated) *) | `Json (* -json (deprecated) *) | `Validate (* -validate (deprecated) *) ] type conv = [ `Ppx of string list | `Camlp4 of string list ] let parse_ocaml_version () = let re = Str.regexp "^\\([0-9]+\\)\\.\\([0-9]+\\)" in if Str.string_match re Sys.ocaml_version 0 then let major = Str.matched_group 1 Sys.ocaml_version in let minor = Str.matched_group 2 Sys.ocaml_version in Some (int_of_string major, int_of_string minor) else None let get_default_name_overlap ocaml_version = match ocaml_version with | Some (major, minor) when major < 4 -> false | Some (4, 0) -> false | _ -> true let main () = let pos_fname = ref None in let pos_lnum = ref None in let files = ref [] in let opens = ref [] in let with_typedefs = ref None in let with_create = ref None in let with_fundefs = ref None in let all_rec = ref false in let out_prefix = ref None in let mode = ref (None : mode option) in let std_json = ref false in let j_preprocess_input = ref None in let j_defaults = ref false in let unknown_field_handler = ref None in let constr_mismatch_handler = ref None in let type_aliases = ref None in let ocaml_version = parse_ocaml_version () in let name_overlap = ref (get_default_name_overlap ocaml_version) in let set_opens s = let l = Str.split (Str.regexp " *, *\\| +") s in opens := List.rev_append l !opens in let pp_convs : conv ref = ref (`Ppx []) in let options = [ "-type-conv", Arg.String (fun s -> pp_convs := `Camlp4 (Str.split (Str.regexp ",") s)), " GEN1,GEN2,... Insert 'with GEN1, GEN2, ...' after OCaml type definitions for the type-conv preprocessor "; "-deriving-conv", Arg.String (fun s -> pp_convs := `Ppx (Str.split (Str.regexp ",") s)), " GEN1,GEN2,... Insert 'with GEN1, GEN2, ...' after OCaml type definitions for the ppx_deriving preprocessor "; "-t", Arg.Unit (fun () -> set_once "output type" mode `T; set_once "no function definitions" with_fundefs false), " Produce files example_t.mli and example_t.ml containing OCaml type definitions derived from example.atd."; "-b", Arg.Unit (fun () -> set_once "output type" mode `B), " Produce files example_b.mli and example_b.ml containing OCaml serializers and deserializers for the Biniou data format from the specifications in example.atd."; "-j", Arg.Unit (fun () -> set_once "output type" mode `J), " Produce files example_j.mli and example_j.ml containing OCaml serializers and deserializers for the JSON data format from the specifications in example.atd."; "-v", Arg.Unit (fun () -> set_once "output type" mode `V), " Produce files example_v.mli and example_v.ml containing OCaml functions for creating records and validators from the specifications in example.atd."; "-dep", Arg.Unit (fun () -> set_once "output type" mode `Dep), " Output Make-compatible dependencies for all possible products of atdgen -t, -b, -j and -v, and exit."; "-list", Arg.Unit (fun () -> set_once "output type" mode `List), " Output a space-separated list of all possible products of atdgen -t, -b, -j and -v, and exit."; "-o", Arg.String (fun s -> let out = match s with "-" -> `Stdout | s -> `Files s in set_once "output prefix" out_prefix out), "[ PREFIX | - ] Use this prefix for the generated files, e.g. 'foo/bar' for foo/bar.ml and foo/bar.mli. `-' designates stdout and produces code of the form struct ... end : sig ... end"; "-biniou", Arg.Unit (fun () -> set_once "output type" mode `Biniou), " [deprecated in favor of -t and -b] Produce serializers and deserializers for Biniou including OCaml type definitions (default)."; "-json", Arg.Unit (fun () -> set_once "output type" mode `Json), " [deprecated in favor of -t and -j] Produce serializers and deserializers for JSON including OCaml type definitions."; "-j-std", Arg.Unit (fun () -> std_json := true), " Convert tuples and variants into standard JSON and refuse to print NaN and infinities (implying -json mode unless another mode is specified)."; "-std-json", Arg.Unit (fun () -> std_json := true), " [deprecated in favor of -j-std] Same as -j-std."; "-j-pp", Arg.String (fun s -> set_once "-j-pp" j_preprocess_input s), " OCaml function of type (string -> string) applied on the input of each *_of_string function generated by atdgen (JSON mode). This is originally intended for UTF-8 validation of the input which is not performed by atdgen."; "-j-defaults", Arg.Set j_defaults, " Output JSON record fields even if their value is known to be the default."; "-j-strict-fields", Arg.Unit ( fun () -> set_once "unknown field handler" unknown_field_handler "!Ag_util.Json.unknown_field_handler" ), " Call !Ag_util.Json.unknown_field_handler for every unknown JSON field found in the input instead of simply skipping them. The initial behavior is to raise an exception."; "-j-custom-fields", Arg.String ( fun s -> set_once "unknown field handler" unknown_field_handler s ), "FUNCTION Call the given function of type (string -> unit) for every unknown JSON field found in the input instead of simply skipping them. See also -j-strict-fields."; "-j-strict-constrs", Arg.Unit ( fun () -> set_once "constructor mismatch handler" constr_mismatch_handler "!Ag_util.Json.constr_mismatch_handler" ), " Given a record type of the form { t: string; v : v }, this option allows the user to define a runtime conflict handler. A conflict occurs when trying to serialize an OCaml record such as { t = \"A\"; v = `B } into JSON. A correct record might be { t = \"B\"; v = `B } or { t = \"A\"; v = `A 123 }. With this option, !Ag_util.Json.constr_mismatch_handler is called for every mismatched constructor field value and value field constructor in the data structures to output instead of simply serializing them. The initial behavior is to raise an exception."; "-validate", Arg.Unit (fun () -> set_once "output type" mode `Validate), " [deprecated in favor of -t and -v] Produce data validators from annotations where x is a user-written validator to be applied on a specific node. This is typically used in conjunction with -extend because user-written validators depend on the type definitions."; "-extend", Arg.String (fun s -> type_aliases := Some s), "MODULE Assume that all type definitions are provided by the specified module unless otherwise annotated. Type aliases are created for each type, e.g. type t = Module.t"; "-open", Arg.String set_opens, "MODULE1,MODULE2,... List of modules to open (comma-separated or space-separated)"; "-nfd", Arg.Unit (fun () -> set_once "no function definitions" with_fundefs false), " Do not dump OCaml function definitions"; "-ntd", Arg.Unit (fun () -> set_once "no type definitions" with_typedefs false), " Do not dump OCaml type definitions"; "-pos-fname", Arg.String (set_once "pos-fname" pos_fname), "FILENAME Source file name to use for error messages (default: input file name)"; "-pos-lnum", Arg.Int (set_once "pos-lnum" pos_lnum), "LINENUM Source line number of the first line of the input (default: 1)"; "-rec", Arg.Set all_rec, " Keep OCaml type definitions mutually recursive"; "-o-name-overlap", Arg.Set name_overlap, " Accept records and classic (non-polymorphic) variants with identical field or constructor names in the same module. Overlapping names are supported in OCaml since version 4.01. Duplicate name checking will be skipped, and type annotations will be included in the implementation to disambiguate names. This is the default if atdgen was compiled for OCaml >= 4.01.0"; "-o-no-name-overlap", Arg.Clear name_overlap, " Disallow records and classic (non-polymorphic) variants with identical field or constructor names in the same module. This is the default if atdgen was compiled for OCaml < 4.01.0"; "-version", Arg.Unit (fun () -> print_endline Ag_version.version; exit 0), " Print the version identifier of atdgen and exit."; ] in let msg = sprintf "\ Generate OCaml code offering: * OCaml type definitions translated from ATD file (-t) * serializers and deserializers for Biniou (-b) * serializers and deserializers for JSON (-j) * record-creating functions supporting default fields (-v) * user-specified data validators (-v) Recommended usage: %s (-t|-b|-j|-v|-dep|-list) example.atd" Sys.argv.(0) in Arg.parse options (fun file -> files := file :: !files) msg; if (!std_json || !unknown_field_handler <> None || !constr_mismatch_handler <> None) && !mode = None then set_once "output mode" mode `Json; let mode = match !mode with None -> `Biniou | Some x -> x in let with_create = match !with_create with Some x -> x | None -> match mode with `T | `B | `J -> false | `V -> true | `Biniou | `Json | `Validate -> true | `Dep | `List -> true (* don't care *) in let force_defaults = match mode with `J | `Json -> !j_defaults | `T | `B | `Biniou | `V | `Validate | `Dep | `List -> false (* don't care *) in let atd_file = match !files with [s] -> Some s | [] -> None | _ -> Arg.usage options msg; exit 1 in let base_ocaml_prefix = match !out_prefix, atd_file with Some x, _ -> x | None, Some file -> `Files ( if Filename.check_suffix file ".atd" then Filename.chop_extension file else file ) | None, None -> `Stdout in let base_prefix, ocaml_prefix = match base_ocaml_prefix with `Stdout -> None, `Stdout | `Files base -> Some base, `Files (match mode with `T -> base ^ "_t" | `B -> base ^ "_b" | `J -> base ^ "_j" | `V -> base ^ "_v" | _ -> base ) in let type_aliases = match base_prefix with None -> (match mode with `B | `J | `V -> Some "T" | _ -> None ) | Some base -> match !type_aliases with Some _ as x -> x | None -> (match mode with `B | `J | `V -> Some (String.capitalize (Filename.basename base) ^ "_t") | _ -> None ) in let get_base_prefix () = match base_prefix with None -> failwith "Undefined output file names" | Some s -> s in match mode with `Dep -> print_deps (get_base_prefix ()) | `List -> print_file_list (get_base_prefix ()) | `T | `B | `J | `V | `Biniou | `Json | `Validate -> let opens = List.rev !opens in let make_ocaml_files = match mode with `T -> Ag_ob_emit.make_ocaml_files | `B | `Biniou -> Ag_ob_emit.make_ocaml_files | `J | `Json -> Ag_oj_emit.make_ocaml_files ~std: !std_json ~unknown_field_handler: !unknown_field_handler ~constr_mismatch_handler: !constr_mismatch_handler ~preprocess_input: !j_preprocess_input | `V | `Validate -> Ag_ov_emit.make_ocaml_files | _ -> assert false in let with_default default = function None -> default | Some x -> x in make_ocaml_files ~pp_convs: !pp_convs ~opens ~with_typedefs: (with_default true !with_typedefs) ~with_create ~with_fundefs: (with_default true !with_fundefs) ~all_rec: !all_rec ~pos_fname: !pos_fname ~pos_lnum: !pos_lnum ~type_aliases ~force_defaults ~ocaml_version ~name_overlap: !name_overlap atd_file ocaml_prefix let () = try main () with Atd_ast.Atd_error s | Failure s -> flush stdout; eprintf "%s\n%!" s; exit 1 | e -> raise e atdgen-1.9.1/src/ag_mapping.ml000066400000000000000000000125101273120334000162010ustar00rootroot00000000000000open Printf open Ag_error type loc = Atd_ast.loc let annot_error loc = Ag_error.error loc "Invalid annotation" type loc_id = string (* Generic mapping, based on the core ATD types *) type ('a, 'b) mapping = [ `Unit of (loc * 'a * 'b) | `Bool of (loc * 'a * 'b) | `Int of (loc * 'a * 'b) | `Float of (loc * 'a * 'b) | `String of (loc * 'a * 'b) | `Sum of (loc * ('a, 'b) variant_mapping array * 'a * 'b) | `Record of (loc * ('a, 'b) field_mapping array * 'a * 'b) | `Tuple of (loc * ('a, 'b) cell_mapping array * 'a * 'b) | `List of (loc * ('a, 'b) mapping * 'a * 'b) | `Option of (loc * ('a, 'b) mapping * 'a * 'b) | `Nullable of (loc * ('a, 'b) mapping * 'a * 'b) | `Wrap of (loc * ('a, 'b) mapping * 'a * 'b) | `Name of (loc * string * ('a, 'b) mapping list * 'a option * 'b option) | `External of (loc * string * ('a, 'b) mapping list * 'a * 'b) | `Tvar of (loc * string) ] and ('a, 'b) cell_mapping = { cel_loc : loc; cel_value : ('a, 'b) mapping; cel_arepr : 'a; cel_brepr : 'b } and ('a, 'b) field_mapping = { f_loc : loc; f_name : string; f_kind : Atd_ast.field_kind; f_value : ('a, 'b) mapping; f_arepr : 'a; f_brepr : 'b } and ('a, 'b) variant_mapping = { var_loc : loc; var_cons : string; var_arg : ('a, 'b) mapping option; var_arepr : 'a; var_brepr : 'b } type ('a, 'b) def = { def_loc : loc; def_name : string; def_param : string list; def_value : ('a, 'b) mapping option; def_arepr : 'a; def_brepr : 'b; } let as_abstract = function `Name (_, (loc, "abstract", l), a) -> if l <> [] then error loc "\"abstract\" takes no type parameters"; Some (loc, a) | _ -> None let is_abstract x = as_abstract x <> None let loc_of_mapping x = match (x : (_, _) mapping) with `Unit (loc, _, _) | `Bool (loc, _, _) | `Int (loc, _, _) | `Float (loc, _, _) | `String (loc, _, _) | `Sum (loc, _, _, _) | `Record (loc, _, _, _) | `Tuple (loc, _, _, _) | `List (loc, _, _, _) | `Option (loc, _, _, _) | `Nullable (loc, _, _, _) | `Wrap (loc, _, _, _) | `Name (loc, _, _, _, _) | `External (loc, _, _, _, _) | `Tvar (loc, _) -> loc module Env = Map.Make (String) let rec subst env (x : (_, _) mapping) = match x with `Unit (loc, _, _) | `Bool (loc, _, _) | `Int (loc, _, _) | `Float (loc, _, _) | `String (loc, _, _) -> x | `Sum (loc, ar, a, b) -> `Sum (loc, Array.map (subst_variant env) ar, a, b) | `Record (loc, ar, a, b) -> `Record (loc, Array.map (subst_field env) ar, a, b) | `Tuple (loc, ar, a, b) -> `Tuple (loc, Array.map (subst_cell env) ar, a, b) | `List (loc, x, a, b) -> `List (loc, subst env x, a, b) | `Option (loc, x, a, b) -> `Option (loc, subst env x, a, b) | `Nullable (loc, x, a, b) -> `Nullable (loc, subst env x, a, b) | `Wrap (loc, x, a, b) -> `Wrap (loc, subst env x, a, b) | `Name (loc, name, args, a, b) -> `Name (loc, name, List.map (subst env) args, a, b) | `External (loc, name, args, a, b) -> `External (loc, name, List.map (subst env) args, a, b) | `Tvar (loc, s) -> try Env.find s env with Not_found -> invalid_arg (sprintf "Ag_mapping.subst_var: '%s" s) and subst_variant env x = match x.var_arg with None -> x | Some v -> { x with var_arg = Some (subst env v) } and subst_field env x = { x with f_value = subst env x.f_value } and subst_cell env x = { x with cel_value = subst env x.cel_value } (* Substitute type variables param in x by args *) let apply param x args = if List.length param <> List.length args then invalid_arg "Ag_mapping.apply"; let env = List.fold_left2 (fun env var value -> Env.add var value env) Env.empty param args in subst env x let rec find_name loc env visited name = if List.mem name visited then error loc "Cyclic type definition" else let param, x = Env.find name env in (param, deref_expr env (name :: visited) x) and deref_expr env visited x = match x with `Name (loc, name, args, _, _) -> (try let param, x = find_name loc env visited name in apply param x args with Not_found -> x) | _ -> x let flatten l = List.flatten (List.map snd l) let make_deref (l : (bool * ('a, 'b) def list) list) : (('a, 'b) mapping -> ('a, 'b) mapping) = let defs = List.fold_left (fun env d -> match d.def_value with None -> env | Some v -> Env.add d.def_name (d.def_param, v) env) Env.empty (flatten l) in fun x -> deref_expr defs [] x (* Resolve names and unwrap `wrap` constructs (discarding annotations along the way) *) let rec unwrap (deref: ('a, 'b) mapping -> ('a, 'b) mapping) x = match deref x with | `Wrap (loc, x, a, b) -> unwrap deref x | x -> x (* This is for debugging *) let constructor : ('a, 'b) mapping -> string = function | `Unit _ -> "Unit" | `Bool _ -> "Bool" | `Int _ -> "Int" | `Float _ -> "Float" | `String _ -> "String" | `Sum _ -> "Sum" | `Record _ -> "Record" | `Tuple _ -> "Tuple" | `List _ -> "List" | `Option _ -> "Option" | `Nullable _ -> "Nullable" | `Wrap _ -> "Wrap" | `Name (loc, name, _, _, _) -> "Name " ^ name | `External _ -> "External" | `Tvar _ -> "Tvar" atdgen-1.9.1/src/ag_ob_emit.ml000066400000000000000000001274121273120334000161740ustar00rootroot00000000000000(* OCaml code generator for the biniou format. *) open Printf open Atd_ast open Ag_error open Ag_mapping open Ag_ob_mapping open Ag_ob_spe (* OCaml code generator (biniou readers and writers) *) let name_of_var s = "_" ^ s let make_ocaml_biniou_intf ~with_create buf deref defs = List.iter ( fun x -> let s = x.def_name in if s <> "" && s.[0] <> '_' && x.def_value <> None then ( let full_name = Ag_ox_emit.get_full_type_name x in let writer_params = String.concat "" ( List.map (fun s -> sprintf "\n Bi_io.node_tag ->\ \n (Bi_outbuf.t -> '%s -> unit) ->\ \n (Bi_outbuf.t -> '%s -> unit) ->" s s) x.def_param ) in let reader_params = String.concat "" ( List.map ( fun s -> sprintf "\n (Bi_io.node_tag -> (Bi_inbuf.t -> '%s)) ->\ \n (Bi_inbuf.t -> '%s) ->" s s ) x.def_param ) in bprintf buf "(* Writers for type %s *)\n\n" s; bprintf buf "\ val %s_tag : Bi_io.node_tag (** Tag used by the writers for type {!%s}. Readers may support more than just this tag. *) " s s; bprintf buf "\ val write_untagged_%s :%s Bi_outbuf.t -> %s -> unit (** Output an untagged biniou value of type {!%s}. *) " s writer_params full_name s; bprintf buf "\ val write_%s :%s Bi_outbuf.t -> %s -> unit (** Output a biniou value of type {!%s}. *) " s writer_params full_name s; bprintf buf "\ val string_of_%s :%s ?len:int -> %s -> string (** Serialize a value of type {!%s} into a biniou string. *) " s writer_params full_name s; bprintf buf "(* Readers for type %s *)\n\n" s; bprintf buf "\ val get_%s_reader :%s Bi_io.node_tag -> (Bi_inbuf.t -> %s) (** Return a function that reads an untagged biniou value of type {!%s}. *) " s reader_params full_name s; bprintf buf "\ val read_%s :%s Bi_inbuf.t -> %s (** Input a tagged biniou value of type {!%s}. *) " s reader_params full_name s; bprintf buf "\ val %s_of_string :%s ?pos:int -> string -> %s (** Deserialize a biniou value of type {!%s}. @param pos specifies the position where reading starts. Default: 0. *) " s reader_params full_name s; if with_create && Ag_ox_emit.is_exportable x then let create_record_intf, create_record_impl = Ag_ox_emit.make_record_creator deref x in bprintf buf "%s" create_record_intf; bprintf buf "\n"; ) ) (flatten defs) let rec get_biniou_tag (x : ob_mapping) = match x with `Unit (loc, `Unit, `Unit) -> "Bi_io.unit_tag" | `Bool (loc, `Bool, `Bool) -> "Bi_io.bool_tag" | `Int (loc, `Int o, `Int b) -> (match b with `Uvint -> "Bi_io.uvint_tag" | `Svint -> "Bi_io.svint_tag" | `Int8 -> "Bi_io.int8_tag" | `Int16 -> "Bi_io.int16_tag" | `Int32 -> "Bi_io.int32_tag" | `Int64 -> "Bi_io.int64_tag" ) | `Float (loc, `Float, `Float b) -> (match b with `Float32 -> "Bi_io.float32_tag" | `Float64 -> "Bi_io.float64_tag" ) | `String (loc, `String, `String) -> "Bi_io.string_tag" | `Sum (loc, a, `Sum x, `Sum) -> "Bi_io.variant_tag" | `Record (loc, a, `Record o, `Record) -> "Bi_io.record_tag" | `Tuple (loc, a, `Tuple, `Tuple) -> "Bi_io.tuple_tag" | `List (loc, x, `List o, `List b) -> (match b with `Array -> "Bi_io.array_tag" | `Table -> "Bi_io.table_tag" ) | `Option (loc, x, `Option, `Option) | `Nullable (loc, x, `Nullable, `Nullable) -> "Bi_io.num_variant_tag" | `Wrap (loc, x, `Wrap _, `Wrap) -> get_biniou_tag x | `Name (loc, s, args, None, None) -> sprintf "%s_tag" s | `External (loc, s, args, `External (types_module, main_module, ext_name), `External) -> sprintf "%s.%s_tag" main_module ext_name | `Tvar (loc, s) -> sprintf "%s_tag" (name_of_var s) | _ -> assert false let nth name i len = let l = Array.to_list (Array.init len (fun j -> if i = j then name else "_")) in String.concat ", " l let get_fields deref a = List.map ( fun x -> let ocaml_fname, ocaml_default, optional, unwrapped = match x.f_arepr, x.f_brepr with `Field o, `Field b -> let ocaml_default = match x.f_kind with `With_default -> (match o.Ag_ocaml.ocaml_default with None -> let d = Ag_ocaml.get_implicit_ocaml_default deref x.f_value in if d = None then error x.f_loc "Missing default field value" else d | Some _ as default -> default ) | `Optional -> Some "None" | `Required -> None in let optional = match x.f_kind with `Optional | `With_default -> true | `Required -> false in o.Ag_ocaml.ocaml_fname, ocaml_default, optional, b.Ag_biniou.biniou_unwrapped | _ -> assert false in (x, ocaml_fname, ocaml_default, optional, unwrapped) ) (Array.to_list a) let unopt = function None -> assert false | Some x -> x let rec get_writer_name ?(paren = false) ?name_f ~tagged (x : ob_mapping) : string = let name_f = match name_f with Some f -> f | None -> if tagged then (fun s -> "write_" ^ s) else (fun s -> "write_untagged_" ^ s) in let un = if tagged then "" else "untagged_" in match x with `Unit (loc, `Unit, `Unit) -> sprintf "Bi_io.write_%sunit" un | `Bool (loc, `Bool, `Bool) -> sprintf "Bi_io.write_%sbool" un | `Int (loc, `Int o, `Int b) -> (match o, b with `Int, `Uvint -> sprintf "Bi_io.write_%suvint" un | `Int, `Svint -> sprintf "Bi_io.write_%ssvint" un | `Char, `Int8 -> sprintf "Bi_io.write_%schar" un | `Int, `Int8 -> sprintf "Bi_io.write_%sint8" un | `Int, `Int16 -> sprintf "Bi_io.write_%sint16" un | `Int32, `Int32 -> sprintf "Bi_io.write_%sint32" un | `Int64, `Int64 -> sprintf "Bi_io.write_%sint64" un | _ -> error loc "Unsupported combination of OCaml/Biniou int types" ) | `Float (loc, `Float, `Float b) -> (match b with `Float32 -> sprintf "Bi_io.write_%sfloat32" un | `Float64 -> sprintf "Bi_io.write_%sfloat64" un ) | `String (loc, `String, `String) -> sprintf "Bi_io.write_%sstring" un | `Tvar (loc, s) -> sprintf "write_%s%s" un (name_of_var s) | `Name (loc, s, args, None, None) -> let l = List.map get_writer_names args in let s = String.concat " " (name_f s :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | `External (loc, s, args, `External (types_module, main_module, ext_name), `External) -> let f = main_module ^ "." ^ name_f ext_name in let l = List.map get_writer_names args in let s = String.concat " " (f :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | _ -> assert false and get_writer_names x = let tag = get_biniou_tag x in let write_untagged = get_writer_name ~paren:true ~tagged:false x in let write = get_writer_name ~paren:true ~tagged:true x in String.concat " " [ tag; write_untagged; write ] let get_left_writer_name ~tagged name param = let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_writer_name ~tagged (`Name (dummy_loc, name, args, None, None)) let get_left_to_string_name name param = let name_f s = "string_of_" ^ s in let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_writer_name ~tagged:true ~name_f (`Name (dummy_loc, name, args, None, None)) (* let make_writer_name tagged loc name args = let un = if tagged then "" else "untagged_" in let f = sprintf "write_%s%s" un name in let l = List.map ( function `Tvar (loc, s) -> let name = name_of_var s in (* TODO (incomplete) *) [ sprintf "%s_tag" name; sprintf "write_%s" name ] | _ -> assert false ) args in String.concat " " (f :: List.flatten l) *) let rec get_reader_name ?(paren = false) ?name_f ~tagged (x : ob_mapping) : string = let name_f = match name_f with Some f -> f | None -> if tagged then (fun s -> "read_" ^ s) else (fun s -> sprintf "get_%s_reader" s) in let xreader s = if tagged then sprintf "Ag_ob_run.read_%s" s else sprintf "Ag_ob_run.get_%s_reader" s in match x with `Unit (loc, `Unit, `Unit) -> xreader "unit" | `Bool (loc, `Bool, `Bool) -> xreader "bool" | `Int (loc, `Int o, `Int b) -> (match o, b with `Int, `Uvint | `Int, `Svint | `Int, `Int8 | `Int, `Int16 -> xreader "int" | `Char, `Int8 -> xreader "char" | `Int32, `Int32 -> xreader "int32" | `Int64, `Int64 -> xreader "int64" | _ -> error loc "Unsupported combination of OCaml/Biniou int types" ) | `Float (loc, `Float, `Float b) -> (match b with `Float32 -> xreader "float32" | `Float64 -> xreader "float64" ) | `String (loc, `String, `String) -> xreader "string" | `Tvar (loc, s) -> let name = name_of_var s in if tagged then sprintf "read_%s" name else sprintf "get_%s_reader" name | `Name (loc, s, args, None, None) -> let l = List.map get_reader_names args in let s = String.concat " " (name_f s :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | `External (loc, s, args, `External (types_module, main_module, ext_name), `External) -> let f = main_module ^ "." ^ name_f ext_name in let l = List.map get_reader_names args in let s = String.concat " " (f :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | _ -> assert false and get_reader_names x = let get_reader = get_reader_name ~paren:true ~tagged:false x in let reader = get_reader_name ~paren:true ~tagged:true x in String.concat " " [ get_reader; reader ] let get_left_reader_name ~tagged name param = let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_reader_name ~tagged (`Name (dummy_loc, name, args, None, None)) let get_left_of_string_name name param = let name_f s = s ^ "_of_string" in let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_reader_name ~name_f ~tagged:true (`Name (dummy_loc, name, args, None, None)) let rec make_writer ~tagged deref (x : ob_mapping) : Ag_indent.t list = let un = if tagged then "" else "untagged_" in match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ | `Name _ | `External _ | `Tvar _ -> [ `Line (get_writer_name ~tagged x) ] | `Sum (loc, a, `Sum x, `Sum) -> let tick = match x with `Classic -> "" | `Poly -> "`" in let match_ = [ `Line "match x with"; `Block ( Array.to_list ( Array.map (fun x -> `Inline (make_variant_writer deref tick x)) a ) ) ] in let body = if tagged then `Line "Bi_io.write_tag ob Bi_io.variant_tag;" :: match_ else match_ in [ `Annot ("fun", `Line "fun ob x ->"); `Block body; ] | `Record (loc, a, `Record o, `Record) -> let body = make_record_writer deref tagged a o in [ `Annot ("fun", `Line "fun ob x ->"); `Block body; ] | `Tuple (loc, a, `Tuple, `Tuple) -> let main = let len = Array.length a in let a = Array.mapi ( fun i x -> [ `Line "("; `Block [ `Line (sprintf "let %s = x in (" (nth "x" i len)); `Block (make_writer ~tagged:true deref x.cel_value); `Line ") ob x"; ]; `Line ");" ] ) a in [ `Line (sprintf "Bi_vint.write_uvint ob %i;" len); `Inline (List.flatten (Array.to_list a)) ] in let body = if tagged then `Line "Bi_io.write_tag ob Bi_io.tuple_tag;" :: main else main in [ `Annot ("fun", `Line "fun ob x ->"); `Block body; ] | `List (loc, x, `List o, `List b) -> (match o, b with `List, `Array -> let tag = get_biniou_tag x in [ `Line (sprintf "Ag_ob_run.write_%slist" un); `Block [ `Line tag; `Line "("; `Block (make_writer ~tagged:false deref x); `Line ")"; ] ] | `Array, `Array -> let tag = get_biniou_tag x in [ `Line (sprintf "Ag_ob_run.write_%sarray" un); `Block [ `Line tag; `Line "("; `Block (make_writer ~tagged deref x); `Line ")"; ] ] | list_kind, `Table -> let body = make_table_writer deref tagged list_kind x in [ `Annot ("fun", `Line "fun ob x ->"); `Block body; ] ) | `Option (loc, x, `Option, `Option) | `Nullable (loc, x, `Nullable, `Nullable) -> [ `Line (sprintf "Ag_ob_run.write_%soption (" un); `Block (make_writer ~tagged:true deref x); `Line ")"; ] | `Wrap (loc, x, `Wrap o, `Wrap) -> let simple_writer = make_writer ~tagged deref x in (match o with None -> simple_writer | Some { Ag_ocaml.ocaml_wrap_t; ocaml_wrap; ocaml_unwrap } -> [ `Line "fun ob x -> ("; `Block [ `Line (sprintf "let x = ( %s ) x in (" ocaml_unwrap); `Block simple_writer; `Line ") ob x)"; ] ] ) | _ -> assert false and make_variant_writer deref tick x : Ag_indent.t list = let o = match x.var_arepr, x.var_brepr with `Variant o, `Variant -> o | _ -> assert false in let ocaml_cons = o.Ag_ocaml.ocaml_cons in match x.var_arg with None -> let h = Bi_io.string_of_hashtag (Bi_io.hash_name x.var_cons) false in [ `Line (sprintf "| %s%s -> Bi_outbuf.add_char4 ob %C %C %C %C" tick ocaml_cons h.[0] h.[1] h.[2] h.[3]) ] | Some v -> let h = Bi_io.string_of_hashtag (Bi_io.hash_name x.var_cons) true in [ `Line (sprintf "| %s%s x ->" tick ocaml_cons); `Block [ `Line (sprintf "Bi_outbuf.add_char4 ob %C %C %C %C;" h.[0] h.[1] h.[2] h.[3]); `Line "("; `Block (make_writer ~tagged:true deref v); `Line ") ob x" ] ] and make_record_writer deref tagged a record_kind = let dot = match record_kind with `Record -> "." | `Object -> "#" in let fields = get_fields deref a in let write_length = (* count the number of defined optional fields in order to determine the length of the record *) let min_len = List.fold_left (fun n (_, _, _, opt, _) -> if opt then n else n + 1) 0 fields in let max_len = List.length fields in if min_len = max_len then [ `Line (sprintf "Bi_vint.write_uvint ob %i;" max_len) ] else [ (* Using a ref because many "let len = ... len + 1 in" cause ocamlopt to take a very long time to finish *) `Line (sprintf "let len = ref %i in" min_len); `Inline ( List.fold_right ( fun (x, ocaml_fname, default, opt, unwrap) l -> if opt then let getfield = sprintf "let x_%s = x%s%s in" ocaml_fname dot ocaml_fname in let setlen = sprintf "if x_%s != %s then incr len;" ocaml_fname (unopt default) in `Line getfield :: `Line setlen :: l else l ) fields [] ); `Line "Bi_vint.write_uvint ob !len;" ] in let write_fields = List.map ( fun (x, ocaml_fname, ocaml_default, optional, unwrapped) -> let f_value = if unwrapped then Ag_ocaml.unwrap_option deref x.f_value else x.f_value in let write_field_tag = let s = Bi_io.string_of_hashtag (Bi_io.hash_name x.f_name) true in sprintf "Bi_outbuf.add_char4 ob %C %C %C %C;" s.[0] s.[1] s.[2] s.[3] in let app v = [ `Line write_field_tag; `Line "("; `Block (make_writer ~tagged:true deref f_value); `Line (sprintf ") ob %s;" v); ] in let v = if optional then sprintf "x_%s" ocaml_fname else sprintf "x%s%s" dot ocaml_fname in if unwrapped then [ `Line (sprintf "(match %s with None -> () | Some x ->" v); `Block (app "x"); `Line ");" ] else if optional then [ `Line (sprintf "if %s != %s then (" v (unopt ocaml_default)); `Block (app v); `Line ");" ] else app v ) fields in let main = write_length @ List.flatten write_fields in if tagged then `Line "Bi_io.write_tag ob Bi_io.record_tag;" :: main else main and make_table_writer deref tagged list_kind x = let a, record_kind = match deref x with `Record (_, a, `Record record_kind, `Record) -> a, record_kind | _ -> error (loc_of_mapping x) "Not a record type" in let dot = match record_kind with `Record -> "." | `Object -> "#" in let let_len = match list_kind with `List -> `Line "let len = List.length x in" | `Array -> `Line "let len = Array.length x in" in let iter2 = match list_kind with `List -> "Ag_ob_run.list_iter2" | `Array -> "Ag_ob_run.array_iter2" in let l = Array.to_list a in let write_header = `Line (sprintf "Bi_vint.write_uvint ob %i;" (Array.length a)) :: List.flatten ( List.map ( fun x -> [ `Line (sprintf "Bi_io.write_hashtag ob (%i) true;" (Bi_io.hash_name x.f_name)); `Line (sprintf "Bi_io.write_tag ob %s;" (get_biniou_tag x.f_value)) ] ) l ) in let write_record = List.flatten ( List.map ( fun x -> [ `Line "("; `Block (make_writer ~tagged:false deref x.f_value); `Line ")"; `Block [ `Line (sprintf "ob x%s%s;" dot x.f_name) ] ] ) l ) in let write_items = [ `Line (iter2 ^ " (fun ob x ->"); `Block write_record; `Line ") ob x;" ] in let main = [ let_len; `Line "Bi_vint.write_uvint ob len;"; `Line "if len > 0 then ("; `Block (write_header @ write_items); `Line ");" ] in if tagged then `Line "Bi_io.write_tag ob Bi_io.table_tag;" :: main else main let study_record ~ocaml_version deref fields = let field_assignments = List.fold_right ( fun (x, name, default, opt, unwrap) field_assignments -> let v = match default with None -> assert (not opt); begin match ocaml_version with | Some (maj, min) when (maj > 4 || maj = 4 && min >= 3) -> "Obj.magic (Sys.opaque_identity 0.0)" | _ -> "Obj.magic 0.0" end | Some s -> s in let init = `Line (sprintf "let field_%s = ref (%s) in" name v) in let create = `Line (sprintf "%s = !field_%s;" name name) in (init, create) :: field_assignments ) fields [] in let init_fields, create_record_fields = List.split field_assignments in let n, mapping = List.fold_left ( fun (i, acc) (x, name, default, opt, unwrap) -> if not opt then (i+1, (Some i :: acc)) else (i, (None :: acc)) ) (0, []) fields in let mapping = Array.of_list (List.rev mapping) in let create_record = [ `Line "{"; `Block create_record_fields; `Line "}" ] in let k = n / 31 + (if n mod 31 > 0 then 1 else 0) in let init_bits = Array.to_list ( Array.init k ( fun i -> `Line (sprintf "let bits%i = ref 0 in" i) ) ) in let final_bits = Array.make k 0 in for z0 = 0 to List.length fields - 1 do match mapping.(z0) with None -> () | Some z -> let i = z / 31 in let j = z mod 31 in final_bits.(i) <- final_bits.(i) lor (1 lsl j); done; let set_bit z0 = match mapping.(z0) with None -> [] | Some z -> let i = z / 31 in let j = z mod 31 in [ `Line (sprintf "bits%i := !bits%i lor 0x%x;" i i (1 lsl j)) ] in let check_bits = let bool_expr = String.concat " || " ( Array.to_list ( Array.mapi ( fun i x -> sprintf "!bits%i <> 0x%x" i x ) final_bits ) ) in let bit_fields = let a = Array.init k (fun i -> sprintf "!bits%i" i) in sprintf "[| %s |]" (String.concat "; " (Array.to_list a)) in let field_names = let l = List.fold_right ( fun (x, name, default, opt, unwrap) acc -> if not opt then sprintf "%S" x.f_name :: acc else acc ) fields [] in sprintf "[| %s |]" (String.concat "; " l) in if k = 0 then [] else [ `Line (sprintf "if %s then Ag_ob_run.missing_fields %s %s;" bool_expr bit_fields field_names) ] in init_fields, init_bits, set_bit, check_bits, create_record let wrap_body ~tagged expected_tag body = if tagged then [ `Annot ("fun", `Line "fun ib ->"); `Block [ `Line (sprintf "if Bi_io.read_tag ib <> %i then \ Ag_ob_run.read_error_at ib;" expected_tag); `Inline body; ] ] else [ `Annot ("fun", `Line "fun tag ->"); `Block [ `Line (sprintf "if tag <> %i then \ Ag_ob_run.read_error () else" expected_tag); `Block [ `Line "fun ib ->"; `Block body; ] ] ] let wrap_bodies ~tagged l = if tagged then let cases = List.map ( fun (expected_tag, body) -> `Inline [ `Line (sprintf "| %i -> " expected_tag); `Block body; ] ) l in [ `Line "fun ib ->"; `Block [ `Line "match Bi_io.read_tag ib with"; `Block [ `Inline cases; `Line "| _ -> Ag_ob_run.read_error_at ib" ] ] ] else let cases = List.map ( fun (expected_tag, body) -> `Inline [ `Line (sprintf "| %i -> " expected_tag); `Block [ `Line "(fun ib ->"; `Block body; `Line ")"; ] ] ) l in [ `Line "function"; `Block [ `Inline cases; `Line "| _ -> Ag_ob_run.read_error ()" ] ] let rec make_reader deref ~tagged ~ocaml_version ?type_annot (x : ob_mapping) : Ag_indent.t list = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ | `Name _ | `External _ | `Tvar _ -> [ `Line (get_reader_name ~tagged x) ] | `Sum (loc, a, `Sum x, `Sum) -> let tick = match x with `Classic -> "" | `Poly -> "`" in let body = [ `Line "Bi_io.read_hashtag ib (fun ib h has_arg ->"; `Block [ `Line "match h, has_arg with"; `Block [ `Inline ( Array.to_list ( Array.map (fun x -> `Inline (make_variant_reader ~ocaml_version deref type_annot tick x) ) a ) ); `Line "| _ -> Ag_ob_run.unsupported_variant h has_arg"; ] ]; `Line ")" ] in wrap_body ~tagged Bi_io.variant_tag body | `Record (loc, a, `Record o, `Record) -> (match o with `Record -> () | `Object -> error loc "Sorry, OCaml objects are not supported" ); let body = make_record_reader deref ~ocaml_version ~tagged type_annot a o in wrap_body ~tagged Bi_io.record_tag body | `Tuple (loc, a, `Tuple, `Tuple) -> let body = make_tuple_reader deref ~ocaml_version ~tagged a in wrap_body ~tagged Bi_io.tuple_tag body | `List (loc, x, `List o, `List b) -> (match o, b with `List, `Array -> let f = if tagged then "Ag_ob_run.read_list" else "Ag_ob_run.get_list_reader" in [ `Line (f ^ " ("); `Block (make_reader deref ~ocaml_version ~tagged:false x); `Line ")"; ] | `Array, `Array -> let f = if tagged then "Ag_ob_run.read_array" else "Ag_ob_run.get_array_reader" in [ `Line (f ^ " ("); `Block (make_reader deref ~ocaml_version ~tagged:false x); `Line ")"; ] | list_kind, `Table -> (* Support table format and regular array format *) let body1 = make_table_reader ~ocaml_version deref loc list_kind x in let body2 = let f = match list_kind with `List -> "Ag_ob_run.read_list_value" | `Array -> "Ag_ob_run.read_array_value" in [ `Line (f ^ " ("); `Block (make_reader deref ~tagged:false ~ocaml_version x); `Line ") ib"; ] in wrap_bodies ~tagged [ Bi_io.table_tag, body1; Bi_io.array_tag, body2 ] ) | `Option (loc, x, `Option, `Option) | `Nullable (loc, x, `Nullable, `Nullable) -> let body = [ `Line "match Char.code (Bi_inbuf.read_char ib) with"; `Block [ `Line "| 0 -> None"; `Line "| 0x80 ->"; `Block [ `Line "Some ("; `Block [ `Line "("; `Block (make_reader deref ~tagged:true ~ocaml_version x); `Line ")"; `Block [ `Line "ib"]; ]; `Line ")" ]; `Line "| _ -> Ag_ob_run.read_error_at ib"; ] ] in wrap_body ~tagged Bi_io.num_variant_tag body | `Wrap (loc, x, `Wrap o, `Wrap) -> let simple_reader = make_reader deref ~tagged ~ocaml_version x in (match o with None -> simple_reader | Some { Ag_ocaml.ocaml_wrap } -> if tagged then [ `Line "fun ib ->"; `Block [ `Line (sprintf "( %s ) ((" ocaml_wrap); `Block simple_reader; `Line ") ib)"; ] ] else [ `Line "fun tag ib ->"; `Block [ `Line (sprintf "( %s ) ((" ocaml_wrap); `Block simple_reader; `Line ") tag ib)"; ] ] ) | _ -> assert false and make_variant_reader ~ocaml_version deref type_annot tick x : Ag_indent.t list = let o = match x.var_arepr, x.var_brepr with `Variant o, `Variant -> o | _ -> assert false in let ocaml_cons = o.Ag_ocaml.ocaml_cons in match x.var_arg with None -> let h = Bi_io.hash_name x.var_cons in let typed_cons = Ag_ox_emit.opt_annot type_annot (tick ^ ocaml_cons) in [ `Line (sprintf "| %i, false -> %s" h typed_cons) ] | Some v -> let h = Bi_io.hash_name x.var_cons in [ `Line (sprintf "| %i, true -> (%s%s (" h tick ocaml_cons); `Block [ `Block [ `Line "("; `Block (make_reader deref ~tagged:true ~ocaml_version v); `Line ") ib"; ]; `Line (sprintf ")%s)" (Ag_ox_emit.insert_annot type_annot)); ]; ] and make_record_reader deref ~ocaml_version ~tagged type_annot a record_kind = let fields = get_fields deref a in let init_fields, init_bits, set_bit, check_bits, create_record = study_record ~ocaml_version deref fields in let body = let a = Array.of_list fields in let cases = Array.mapi ( fun i (x, name, _, opt, unwrapped) -> let f_value = if unwrapped then Ag_ocaml.unwrap_option deref x.f_value else x.f_value in let wrap l = if unwrapped then [ `Line "Some ("; `Block l; `Line ")" ] else l in let read_value = [ `Line "("; `Block (make_reader deref ~tagged:true ~ocaml_version f_value); `Line ") ib" ] in `Inline [ `Line (sprintf "| %i ->" (Bi_io.hash_name x.f_name)); `Block [ `Line (sprintf "field_%s := (" name); `Block (wrap read_value); `Line ");"; `Inline (set_bit i); ]; ] ) a in [ `Line "match Bi_io.read_field_hashtag ib with"; `Block [ `Inline (Array.to_list cases); `Line "| _ -> Bi_io.skip ib"; ] ] in [ `Inline init_fields; `Inline init_bits; `Line "let len = Bi_vint.read_uvint ib in"; `Line "for i = 1 to len do"; `Block body; `Line "done;"; `Inline check_bits; `Line "("; `Block create_record; `Line (sprintf "%s)" (Ag_ox_emit.insert_annot type_annot)); ] and make_tuple_reader deref ~tagged ~ocaml_version a = let cells = Array.map ( fun x -> match x.cel_arepr with `Cell f -> x, f.Ag_ocaml.ocaml_default | _ -> assert false ) a in let min_length = let n = ref (Array.length cells) in (try for i = Array.length cells - 1 downto 0 do let x, default = cells.(i) in if default = None then ( n := i + 1; raise Exit ) done with Exit -> ()); !n in let tup_len = Array.length a in let read_cells = List.flatten ( Array.to_list ( Array.mapi ( fun i (x, default) -> let read_value = make_reader deref ~ocaml_version ~tagged:true x.cel_value in let get_value = if i < min_length then [ `Line "("; `Block read_value; `Line ") ib"; ] else [ `Line (sprintf "if len >= %i then (" (i+1)); `Block read_value; `Line ") ib"; `Line "else"; `Block [ `Line (match default with None -> assert false | Some s -> s) ] ] in [ `Line (sprintf "let x%i =" i); `Block get_value; `Line "in" ] ) cells ) ) in let make_tuple = sprintf "(%s)" (String.concat ", " (Array.to_list (Array.mapi (fun i _ -> sprintf "x%i" i) a))) in let req_fields = let acc = ref [] in for i = Array.length cells - 1 downto 0 do let _, default = cells.(i) in if default = None then acc := string_of_int i :: !acc done; sprintf "[ %s ]" (String.concat "; " !acc) in [ `Line "let len = Bi_vint.read_uvint ib in"; `Line (sprintf "if len < %i then Ag_ob_run.missing_tuple_fields len %s;" min_length req_fields); `Inline read_cells; `Line (sprintf "for i = %i to len - 1 do Bi_io.skip ib done;" tup_len); `Line make_tuple ] and make_table_reader deref ~ocaml_version loc list_kind x = let empty_list, to_list = match list_kind with `List -> "[ ]", (fun s -> "Array.to_list " ^ s) | `Array -> "[| |]", (fun s -> s) in let fields = match deref x with `Record (loc, a, `Record o, `Record) -> (match o with `Record -> () | `Object -> error loc "Sorry, OCaml objects are not supported" ); get_fields deref a | _ -> error loc "Not a list or array of records" in let init_fields, init_bits, set_bit, check_bits, create_record = study_record ~ocaml_version deref fields in let cases = Array.to_list ( Array.mapi ( fun i (x, name, default, opt, unwrap) -> `Inline [ `Line (sprintf "| %i ->" (Bi_io.hash_name x.f_name)); `Block [ `Inline (set_bit i); `Line "let read ="; `Block [ `Line "("; `Block (make_reader deref ~tagged:false ~ocaml_version x.f_value); `Line ")"; `Block [ `Line "tag" ] ]; `Line "in"; `Line (sprintf "(fun ib -> field_%s := read ib)" name); ] ] ) (Array.of_list fields) ) in [ `Line "let row_num = Bi_vint.read_uvint ib in"; `Line ("if row_num = 0 then " ^ empty_list); `Line "else"; `Block [ `Line "let col_num = Bi_vint.read_uvint ib in"; `Inline init_fields; `Inline init_bits; `Line "let readers ="; `Block [ `Line "Ag_ob_run.array_init2 col_num ib ("; `Block [ `Line "fun col ib ->"; `Block [ `Line "let h = Bi_io.read_field_hashtag ib in"; `Line "let tag = Bi_io.read_tag ib in"; `Line "match h with"; `Block cases; `Block [ `Line "| _ -> (fun ib -> Bi_io.skip ib)" ] ] ]; `Line ")"; ]; `Line "in"; `Inline check_bits; `Line "let a = Array.make row_num (Obj.magic 0) in"; `Line "for row = 0 to row_num - 1 do"; `Block [ `Line "for i = 0 to Array.length readers - 1 do"; `Block [ `Line "readers.(i) ib" ]; `Line "done;"; `Line "a.(row) <-"; `Block create_record; ]; `Line "done;"; `Line (to_list "a") ] ] let make_ocaml_biniou_writer ~original_types deref is_rec let1 let2 def = let x = match def.def_value with None -> assert false | Some x -> x in let name = def.def_name in let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in let param = def.def_param in let tag = get_biniou_tag (deref x) in let write_untagged = get_left_writer_name ~tagged:false name param in let write = get_left_writer_name ~tagged:true name param in let to_string = get_left_to_string_name name param in let write_untagged_expr = make_writer deref ~tagged:false x in let eta_expand = is_rec && not (Ag_ox_emit.is_function write_untagged_expr) in let needs_annot = Ag_ox_emit.needs_type_annot x in let extra_param, extra_args, type_annot = match eta_expand, needs_annot with | true, false -> " ob x", " ob x", None | true, true -> sprintf " ob (x : %s)" type_constraint, " ob x", None | false, false -> "", "", None | false, true -> "", "", Some (sprintf "_ -> %s -> _" type_constraint) in let type_annot = match Ag_ox_emit.needs_type_annot x with | true -> Some (sprintf "Bi_outbuf.t -> %s -> unit" type_constraint) | false -> None in [ `Line (sprintf "%s %s_tag = %s" let1 name tag); `Line (sprintf "%s %s = (" let2 (Ag_ox_emit.opt_annot_def type_annot (write_untagged ^ extra_param))); `Block (List.map Ag_indent.strip write_untagged_expr); `Line (sprintf ")%s" extra_args); `Line (sprintf "%s %s ob x =" let2 write); `Block [ `Line (sprintf "Bi_io.write_tag ob %s;" tag); `Line (sprintf "%s ob x" write_untagged); ]; `Line (sprintf "%s %s ?(len = 1024) x =" let2 to_string); `Block [ `Line "let ob = Bi_outbuf.create len in"; `Line (sprintf "%s ob x;" write); `Line "Bi_outbuf.contents ob" ] ] let make_ocaml_biniou_reader ~original_types ~ocaml_version deref is_rec let1 let2 def = let x = match def.def_value with None -> assert false | Some x -> x in let name = def.def_name in let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in let param = def.def_param in let get_reader = get_left_reader_name ~tagged:false name param in let read = get_left_reader_name ~tagged:true name param in let of_string = get_left_of_string_name name param in let type_annot = match Ag_ox_emit.needs_type_annot x with | true -> Some type_constraint | false -> None in let get_reader_expr = make_reader deref ~tagged:false ~ocaml_version ?type_annot x in let read_expr = make_reader deref ~tagged:true ~ocaml_version ?type_annot x in let eta_expand1 = is_rec && not (Ag_ox_emit.is_function get_reader_expr) in let eta_expand2 = is_rec && not (Ag_ox_emit.is_function read_expr) in let extra_param1, extra_args1 = if eta_expand1 then " tag", " tag" else "", "" in let extra_param2, extra_args2 = if eta_expand2 then " ib", " ib" else "", "" in [ `Line (sprintf "%s %s%s = (" let1 get_reader extra_param1); `Block (List.map Ag_indent.strip get_reader_expr); `Line (sprintf ")%s" extra_args1); `Line (sprintf "%s %s%s = (" let2 read extra_param2); `Block (List.map Ag_indent.strip read_expr); `Line (sprintf ")%s" extra_args2); `Line (sprintf "%s %s ?pos s =" let2 of_string); `Block [ `Line (sprintf "%s (Bi_inbuf.from_string ?pos s)" read) ] ] let map f = function [] -> [] | x :: l -> let y = f true x in y :: List.map (f false) l let get_let ~is_rec ~is_first = if is_first then if is_rec then "let rec", "and" else "let", "let" else "and", "and" let make_ocaml_biniou_impl ~with_create ~original_types ~ocaml_version buf deref defs = let ll = List.map ( fun (is_rec, l) -> let l = List.filter (fun x -> x.def_value <> None) l in let writers = map ( fun is_first def -> let let1, let2 = get_let ~is_rec ~is_first in make_ocaml_biniou_writer ~original_types deref is_rec let1 let2 def ) l in let readers = map ( fun is_first def -> let let1, let2 = get_let ~is_rec ~is_first in make_ocaml_biniou_reader ~ocaml_version ~original_types deref is_rec let1 let2 def ) l in List.flatten (writers @ readers) ) defs in Atd_indent.to_buffer buf (List.flatten ll); if with_create then List.iter ( fun (is_rec, l) -> let l = List.filter Ag_ox_emit.is_exportable l in List.iter ( fun x -> let intf, impl = Ag_ox_emit.make_record_creator deref x in Buffer.add_string buf impl ) l ) defs (* Glue *) let translate_mapping (l : (bool * Atd_ast.module_body) list) = defs_of_atd_modules l let write_opens buf l = List.iter (fun s -> bprintf buf "open %s\n" s) l; bprintf buf "\n" let make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_biniou_intf ~with_create buf deref defs; Buffer.contents buf let make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types ~ocaml_version ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_biniou_impl ~with_create ~original_types ~ocaml_version buf deref defs; Buffer.contents buf let make_ocaml_files ~opens ~with_typedefs ~with_create ~with_fundefs ~all_rec ~pos_fname ~pos_lnum ~type_aliases ~force_defaults ~name_overlap ~ocaml_version ~pp_convs atd_file out = let ((head, m0), _) = match atd_file with Some file -> Atd_util.load_file ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum file | None -> Atd_util.read_channel ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum stdin in let tsort = if all_rec then function m -> [ (true, m) ] else Atd_util.tsort in let m1 = tsort m0 in let defs1 = translate_mapping m1 in if not name_overlap then Ag_ox_emit.check defs1; Ag_xb_emit.check defs1; let (m1', original_types) = Atd_expand.expand_module_body ~keep_poly:true m0 in let m2 = tsort m1' in (* m0 = original type definitions m1 = original type definitions after dependency analysis m2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = Ag_ocaml.ocaml_of_atd ~pp_convs ~target:`Biniou ~type_aliases (head, m1) in let defs = translate_mapping m2 in let header = let src = match atd_file with None -> "stdin" | Some path -> sprintf "%S" (Filename.basename path) in sprintf "(* Auto-generated from %s *)\n" src in let mli = make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs (Ag_mapping.make_deref defs1) defs1 in let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types ~ocaml_version ocaml_typedefs (Ag_mapping.make_deref defs) defs in Ag_ox_emit.write_ocaml out mli ml atdgen-1.9.1/src/ag_ob_mapping.ml000066400000000000000000000136101273120334000166630ustar00rootroot00000000000000open Printf open Atd_ast open Ag_error open Ag_mapping type o = Ag_ocaml.atd_ocaml_repr type b = Ag_biniou.biniou_repr type ob_mapping = (Ag_ocaml.atd_ocaml_repr, Ag_biniou.biniou_repr) Ag_mapping.mapping type ob_def = (Ag_ocaml.atd_ocaml_repr, Ag_biniou.biniou_repr) Ag_mapping.def (* Translation of the types into the ocaml/biniou mapping. *) let rec mapping_of_expr (x : type_expr) : ob_mapping = match x with `Sum (loc, l, an) -> let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in let biniou_t = `Sum in `Sum (loc, Array.of_list (List.map mapping_of_variant l), ocaml_t, biniou_t) | `Record (loc, l, an) -> let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in let biniou_t = `Record in `Record (loc, Array.of_list (List.map (mapping_of_field ocaml_field_prefix) l), ocaml_t, biniou_t) | `Tuple (loc, l, an) -> let ocaml_t = `Tuple in let biniou_t = `Tuple in `Tuple (loc, Array.of_list (List.map mapping_of_cell l), ocaml_t, biniou_t) | `List (loc, x, an) -> let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in let biniou_t = `List (Ag_biniou.get_biniou_list an) in `List (loc, mapping_of_expr x, ocaml_t, biniou_t) | `Option (loc, x, an) -> let ocaml_t = `Option in let biniou_t = `Option in `Option (loc, mapping_of_expr x, ocaml_t, biniou_t) | `Nullable (loc, x, an) -> let ocaml_t = `Nullable in let biniou_t = `Nullable in `Nullable (loc, mapping_of_expr x, ocaml_t, biniou_t) | `Shared (loc, x, a) -> failwith "Sharing is no longer supported" | `Wrap (loc, x, a) -> let ocaml_t = `Wrap (Ag_ocaml.get_ocaml_wrap loc a) in let json_t = `Wrap in `Wrap (loc, mapping_of_expr x, ocaml_t, json_t) | `Name (loc, (loc2, s, l), an) -> (match s with "unit" -> `Unit (loc, `Unit, `Unit) | "bool" -> `Bool (loc, `Bool, `Bool) | "int" -> let o = Ag_ocaml.get_ocaml_int an in let b = Ag_biniou.get_biniou_int an in `Int (loc, `Int o, `Int b) | "float" -> let b = Ag_biniou.get_biniou_float an in `Float (loc, `Float, `Float b) | "string" -> `String (loc, `String, `String) | s -> `Name (loc, s, List.map mapping_of_expr l, None, None) ) | `Tvar (loc, s) -> `Tvar (loc, s) and mapping_of_cell (loc, x, an) = let default = Ag_ocaml.get_ocaml_default an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Cell { Ag_ocaml.ocaml_default = default; ocaml_fname = ""; ocaml_mutable = false; ocaml_fdoc = doc; } in let biniou_t = `Cell in { cel_loc = loc; cel_value = mapping_of_expr x; cel_arepr = ocaml_t; cel_brepr = biniou_t } and mapping_of_variant = function `Variant (loc, (s, an), o) -> let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Variant { Ag_ocaml.ocaml_cons = ocaml_cons; ocaml_vdoc = doc; } in let biniou_t = `Variant in let arg = match o with None -> None | Some x -> Some (mapping_of_expr x) in { var_loc = loc; var_cons = s; var_arg = arg; var_arepr = ocaml_t; var_brepr = biniou_t } | `Inherit _ -> assert false and mapping_of_field ocaml_field_prefix = function `Field (loc, (s, fk, an), x) -> let fvalue = mapping_of_expr x in let ocaml_default, biniou_unwrapped = match fk, Ag_ocaml.get_ocaml_default an with `Required, None -> None, false | `Optional, None -> Some "None", true | (`Required | `Optional), Some _ -> error loc "Superfluous default OCaml value" | `With_default, Some s -> Some s, false | `With_default, None -> (* will try to determine implicit default value later *) None, false in let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in let doc = Ag_doc.get_doc loc an in { f_loc = loc; f_name = s; f_kind = fk; f_value = fvalue; f_arepr = `Field { Ag_ocaml.ocaml_default = ocaml_default; ocaml_fname = ocaml_fname; ocaml_mutable = ocaml_mutable; ocaml_fdoc = doc; }; f_brepr = `Field { Ag_biniou.biniou_unwrapped = biniou_unwrapped }; } | `Inherit _ -> assert false let def_of_atd (loc, (name, param, an), x) = let ocaml_predef = Ag_ocaml.get_ocaml_predef `Biniou an in let doc = Ag_doc.get_doc loc an in let o = match as_abstract x with Some (loc2, an2) -> (match Ag_ocaml.get_ocaml_module_and_t `Biniou name an with None -> None | Some (types_module, main_module, ext_name) -> let args = List.map (fun s -> `Tvar (loc, s)) param in Some (`External (loc, name, args, `External (types_module, main_module, ext_name), `External) ) ) | None -> Some (mapping_of_expr x) in { def_loc = loc; def_name = name; def_param = param; def_value = o; def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; ocaml_ddoc = doc; }; def_brepr = `Def; } let defs_of_atd_module l = List.map (function `Type def -> def_of_atd def) l let defs_of_atd_modules l = List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module l)) l atdgen-1.9.1/src/ag_ob_run.ml000066400000000000000000000167141273120334000160440ustar00rootroot00000000000000 (* Runtime library *) open Printf exception Error of string (* Error messages *) let error s = raise (Error s) let read_error () = error "Read error" let read_error_at ib = error (sprintf "Read error (%i)" ib.Bi_inbuf.i_pos) let tag_error tag s = error (sprintf "Found wrong tag %i for %s" tag s) let unsupported_variant h has_arg = error (sprintf "Unsupported variant (hash=%i, arg=%B)" h has_arg) let missing_tuple_fields len req_fields = let missing = List.fold_right ( fun i acc -> if i >= len then i :: acc else acc ) req_fields [] in error (sprintf "Missing tuple field%s %s" (if List.length missing > 1 then "s" else "") (String.concat ", " (List.map string_of_int missing))) let missing_fields bit_fields field_names = let acc = ref [] in for z = Array.length field_names - 1 downto 0 do let i = z / 31 in let j = z mod 31 in if bit_fields.(i) land (1 lsl j) = 0 then acc := field_names.(z) :: !acc done; error (sprintf "Missing record field%s %s" (if List.length !acc > 1 then "s" else "") (String.concat ", " !acc)) (* Readers *) let get_unit_reader tag = if tag = Bi_io.unit_tag then Bi_io.read_untagged_unit else tag_error tag "unit" let read_unit ib = if Bi_io.read_tag ib = Bi_io.unit_tag then Bi_io.read_untagged_unit ib else read_error_at ib let get_bool_reader tag = if tag = Bi_io.bool_tag then Bi_io.read_untagged_bool else tag_error tag "bool" let read_bool ib = if Bi_io.read_tag ib = Bi_io.bool_tag then Bi_io.read_untagged_bool ib else read_error_at ib let get_int_reader tag = match tag with 1 -> Bi_io.read_untagged_int8 | 2 -> Bi_io.read_untagged_int16 | 16 -> Bi_io.read_untagged_uvint | 17 -> Bi_io.read_untagged_svint | _ -> tag_error tag "int" let read_int ib = match Bi_io.read_tag ib with 1 -> Bi_io.read_untagged_int8 ib | 2 -> Bi_io.read_untagged_int16 ib | 16 -> Bi_io.read_untagged_uvint ib | 17 -> Bi_io.read_untagged_svint ib | _ -> read_error_at ib let get_char_reader tag = if tag = Bi_io.int8_tag then Bi_io.read_untagged_char else tag_error tag "char" let read_char ib = if Bi_io.read_tag ib = Bi_io.int8_tag then Bi_io.read_untagged_char ib else read_error_at ib let get_int16_reader tag = if tag = Bi_io.int16_tag then Bi_io.read_untagged_int16 else tag_error tag "int16" let read_int16 ib = if Bi_io.read_tag ib = Bi_io.int16_tag then Bi_io.read_untagged_int16 ib else read_error_at ib let get_int32_reader tag = if tag = Bi_io.int32_tag then Bi_io.read_untagged_int32 else tag_error tag "int32" let read_int32 ib = if Bi_io.read_tag ib = Bi_io.int32_tag then Bi_io.read_untagged_int32 ib else read_error_at ib let get_int64_reader tag = if tag = Bi_io.int64_tag then Bi_io.read_untagged_int64 else tag_error tag "int64" let read_int64 ib = if Bi_io.read_tag ib = Bi_io.int64_tag then Bi_io.read_untagged_int64 ib else read_error_at ib let get_float32_reader tag = if tag = Bi_io.float32_tag then Bi_io.read_untagged_float32 else tag_error tag "float32" let get_float64_reader tag = if tag = Bi_io.float64_tag then Bi_io.read_untagged_float64 else tag_error tag "float64" let get_float_reader = get_float64_reader let read_float32 ib = if Bi_io.read_tag ib = Bi_io.float32_tag then Bi_io.read_untagged_float32 ib else read_error_at ib let read_float64 ib = if Bi_io.read_tag ib = Bi_io.float64_tag then Bi_io.read_untagged_float64 ib else read_error_at ib let read_float = read_float64 let get_string_reader tag = if tag = Bi_io.string_tag then Bi_io.read_untagged_string else tag_error tag "string" let read_string ib = if Bi_io.read_tag ib = Bi_io.string_tag then Bi_io.read_untagged_string ib else read_error_at ib let read_array_value get_reader ib = let len = Bi_vint.read_uvint ib in if len = 0 then [| |] else let reader = get_reader (Bi_io.read_tag ib) in let a = Array.make len (reader ib) in for i = 1 to len - 1 do Array.unsafe_set a i (reader ib) done; a let read_list_value get_reader ib = Array.to_list (read_array_value get_reader ib) let get_array_reader get_reader tag = if tag = Bi_io.array_tag then read_array_value get_reader else tag_error tag "array" let get_list_reader get_reader tag = if tag = Bi_io.array_tag then fun ib -> Array.to_list (read_array_value get_reader ib) else tag_error tag "list" let read_array get_reader ib = if Bi_io.read_tag ib = Bi_io.array_tag then read_array_value get_reader ib else read_error_at ib let read_list read ib = Array.to_list (read_array read ib) (* Writers *) let write_tagged tag write buf x = Bi_io.write_tag buf tag; write buf x let write_untagged_option write buf x = match x with None -> Bi_io.write_numtag buf 0 false | Some x -> Bi_io.write_numtag buf 0 true; write buf x let write_option write buf x = Bi_io.write_tag buf Bi_io.num_variant_tag; write_untagged_option write buf x let array_init2 len x f = if len = 0 then [| |] else let a = Array.make len (f 0 x) in for i = 1 to len - 1 do Array.unsafe_set a i (f i x) done; a let array_init3 len x y f = if len = 0 then [| |] else let a = Array.make len (f 0 x y) in for i = 1 to len - 1 do Array.unsafe_set a i (f i x y) done; a let array_iter2 f x a = for i = 0 to Array.length a - 1 do f x (Array.unsafe_get a i) done let array_iter3 f x y a = for i = 0 to Array.length a - 1 do f x y (Array.unsafe_get a i) done let rec list_iter2 f x = function [] -> () | y :: l -> f x y; list_iter2 f x l let rec list_iter3 f x y = function [] -> () | z :: l -> f x y z; list_iter3 f x y l let write_untagged_array cell_tag write buf a = let len = Array.length a in Bi_vint.write_uvint buf len; if len > 0 then ( Bi_io.write_tag buf cell_tag; array_iter2 write buf a ) let write_array cell_tag write buf a = Bi_io.write_tag buf Bi_io.array_tag; write_untagged_array cell_tag write buf a let write_untagged_list cell_tag write buf l = let len = List.length l in Bi_vint.write_uvint buf len; if len > 0 then ( Bi_io.write_tag buf cell_tag; list_iter2 write buf l ) let write_list cell_tag write buf l = Bi_io.write_tag buf Bi_io.array_tag; write_untagged_list cell_tag write buf l (* shortcut for getting the tag of a polymorphic variant since biniou uses the same representation (usefulness?) *) let get_poly_tag (x : [> ]) = let r = Obj.repr x in if Obj.is_block r then (Obj.obj (Obj.field r 0) : int) else (Obj.obj r : int) (* We want an identity function that is not inlined *) type identity_t = { mutable _identity : 'a. 'a -> 'a } let identity_ref = { _identity = (fun x -> x) } let identity x = identity_ref._identity x (* Checking at runtime that our assumptions on unspecified compiler behavior still hold. *) type t = { _a : int option; _b : int; } let create () = { { _a = None; _b = Array.length Sys.argv } with _a = None } let test () = let r = create () in let v = Some 17 in Obj.set_field (Obj.repr r) 0 (Obj.repr v); let safe_r = identity r in (* r._a is inlined by ocamlopt and equals None because the field is supposed to be immutable. *) assert (safe_r._a = v) let () = test () (************************************) atdgen-1.9.1/src/ag_ob_spe.ml000066400000000000000000000003621273120334000160170ustar00rootroot00000000000000 (* Optimization of the biniou representation *) open Ag_mapping open Ag_ob_mapping let get_table_info deref x = match deref x with `Record y -> y | _ -> Ag_error.error (Atd_ast.loc_of_type_expr x) "Not a record type" atdgen-1.9.1/src/ag_ocaml.ml000066400000000000000000000545611273120334000156550ustar00rootroot00000000000000 (* Translation from ATD types into OCaml types and pretty-printing. This is derived from the ATD pretty-printer (atd_print.ml). *) open Printf open Easy_format open Atd_ast open Ag_mapping (* Type mapping from ATD to OCaml *) type atd_ocaml_sum = [ `Classic | `Poly ] type atd_ocaml_record = [ `Record | `Object ] type atd_ocaml_int = [ `Int | `Char | `Int32 | `Int64 | `Float ] type atd_ocaml_list = [ `List | `Array ] type atd_ocaml_wrap = { ocaml_wrap_t : string; ocaml_wrap : string; ocaml_unwrap : string; } type atd_ocaml_field = { ocaml_default : string option; ocaml_fname : string; ocaml_mutable : bool; ocaml_fdoc : Ag_doc.doc option; } type atd_ocaml_variant = { ocaml_cons : string; ocaml_vdoc : Ag_doc.doc option; } type atd_ocaml_def = { ocaml_predef : bool; ocaml_ddoc : Ag_doc.doc option; } type atd_ocaml_repr = [ | `Unit | `Bool | `Int of atd_ocaml_int | `Float | `String | `Sum of atd_ocaml_sum | `Record of atd_ocaml_record | `Tuple | `List of atd_ocaml_list | `Option | `Nullable | `Wrap of atd_ocaml_wrap option | `Name of string | `External of (string * string * string) (* (module providing the type, module providing everything else, type name) *) | `Cell of atd_ocaml_field | `Field of atd_ocaml_field | `Variant of atd_ocaml_variant | `Def of atd_ocaml_def ] type target = [ `Default | `Biniou | `Json | `Validate ] let ocaml_int_of_string s : atd_ocaml_int option = match s with "int" -> Some `Int | "char" -> Some `Char | "int32" -> Some `Int32 | "int64" -> Some `Int64 | "float" -> Some `Float | _ -> None let string_of_ocaml_int (x : atd_ocaml_int) = match x with `Int -> "int" | `Char -> "Char.t" | `Int32 -> "Int32.t" | `Int64 -> "Int64.t" | `Float -> "float" let ocaml_sum_of_string s : atd_ocaml_sum option = match s with "classic" -> Some `Classic | "poly" -> Some `Poly | s -> None let ocaml_record_of_string s : atd_ocaml_record option = match s with "record" -> Some `Record | "object" -> Some `Object | s -> None let ocaml_list_of_string s : atd_ocaml_list option = match s with "list" -> Some `List | "array" -> Some `Array | s -> None let string_of_ocaml_list (x : atd_ocaml_list) = match x with `List -> "list" | `Array -> "Ag_util.ocaml_array" let get_ocaml_int an = Atd_annot.get_field ocaml_int_of_string `Int ["ocaml"] "repr" an let get_ocaml_type_path atd_name an = let x = match atd_name with "unit" -> `Unit | "bool" -> `Bool | "int" -> `Int (get_ocaml_int an) | "float" -> `Float | "string" -> `String | s -> `Name s in match x with `Unit -> "unit" | `Bool -> "bool" | `Int x -> string_of_ocaml_int x | `Float -> "float" | `String -> "string" | `Name s -> s let path_of_target (target : target) = match target with `Default -> [ "ocaml" ] | `Biniou -> [ "ocaml_biniou"; "ocaml" ] | `Json -> [ "ocaml_json"; "ocaml" ] | `Validate -> [ "ocaml_validate"; "ocaml" ] let get_ocaml_sum an = Atd_annot.get_field ocaml_sum_of_string `Poly ["ocaml"] "repr" an let get_ocaml_field_prefix an = Atd_annot.get_field (fun s -> Some s) "" ["ocaml"] "field_prefix" an let get_ocaml_record an = Atd_annot.get_field ocaml_record_of_string `Record ["ocaml"] "repr" an let get_ocaml_list an = Atd_annot.get_field ocaml_list_of_string `List ["ocaml"] "repr" an let get_ocaml_wrap loc an = let module_ = Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "module" an in let default field = match module_ with None -> None | Some s -> Some (sprintf "%s.%s" s field) in let t = Atd_annot.get_field (fun s -> Some (Some s)) (default "t") ["ocaml"] "t" an in let wrap = Atd_annot.get_field (fun s -> Some (Some s)) (default "wrap") ["ocaml"] "wrap" an in let unwrap = Atd_annot.get_field (fun s -> Some (Some s)) (default "unwrap") ["ocaml"] "unwrap" an in match t, wrap, unwrap with None, None, None -> None | Some t, Some wrap, Some unwrap -> Some { ocaml_wrap_t = t; ocaml_wrap = wrap; ocaml_unwrap = unwrap } | _ -> Ag_error.error loc "Incomplete annotation. Missing t, wrap or unwrap" let get_ocaml_cons default an = Atd_annot.get_field (fun s -> Some s) default ["ocaml"] "name" an let get_ocaml_fname default an = Atd_annot.get_field (fun s -> Some s) default ["ocaml"] "name" an let get_ocaml_default an = Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "default" an let get_ocaml_mutable an = Atd_annot.get_flag ["ocaml"] "mutable" an let get_ocaml_predef target an = let path = path_of_target target in Atd_annot.get_flag path "predef" an let get_ocaml_module target an = let path = path_of_target target in let o = Atd_annot.get_field (fun s -> Some (Some s)) None path "module" an in match o with Some s -> Some (s, s) | None -> let o = Atd_annot.get_field (fun s -> Some (Some s)) None path "from" an in match o with None -> None | Some s -> let type_module = s ^ "_t" in let main_module = match target with `Default -> type_module | `Biniou -> s ^ "_b" | `Json -> s ^ "_j" | `Validate -> s ^ "_v" in Some (type_module, main_module) let get_ocaml_t target default an = let path = path_of_target target in Atd_annot.get_field (fun s -> Some s) default path "t" an let get_ocaml_module_and_t target default_name an = match get_ocaml_module target an with None -> None | Some (type_module, main_module) -> Some (type_module, main_module, get_ocaml_t target default_name an) (* OCaml syntax tree *) type ocaml_type_param = string list type ocaml_expr = [ `Sum of (atd_ocaml_sum * ocaml_variant list) | `Record of (atd_ocaml_record * ocaml_field list) | `Tuple of ocaml_expr list | `Name of (string * ocaml_expr list) | `Tvar of string ] and ocaml_variant = string * ocaml_expr option * Ag_doc.doc option and ocaml_field = (string * bool (* is mutable? *)) * ocaml_expr * Ag_doc.doc option type ocaml_def = { o_def_name : (string * ocaml_type_param); o_def_alias : (string * ocaml_type_param) option; o_def_expr : ocaml_expr option; o_def_doc : Ag_doc.doc option } type ocaml_module_item = [ `Type of ocaml_def ] type ocaml_module_body = ocaml_module_item list (* Mapping from ATD to OCaml *) let omap f = function None -> None | Some x -> Some (f x) let rec map_expr (x : type_expr) : ocaml_expr = match x with `Sum (loc, l, an) -> let kind = get_ocaml_sum an in `Sum (kind, List.map map_variant l) | `Record (loc, l, an) -> let kind = get_ocaml_record an in let field_prefix = get_ocaml_field_prefix an in if l = [] then Ag_error.error loc "Empty record (not valid in OCaml)" else `Record (kind, List.map (map_field field_prefix) l) | `Tuple (loc, l, an) -> `Tuple (List.map (fun (_, x, _) -> map_expr x) l) | `List (loc, x, an) -> let s = string_of_ocaml_list (get_ocaml_list an) in `Name (s, [map_expr x]) | `Option (loc, x, an) -> `Name ("option", [map_expr x]) | `Nullable (loc, x, an) -> `Name ("option", [map_expr x]) | `Shared (loc, x, a) -> failwith "Sharing is not supported" | `Wrap (loc, x, a) -> (match get_ocaml_wrap loc a with None -> map_expr x | Some { ocaml_wrap_t } -> `Name (ocaml_wrap_t, []) ) | `Name (loc, (loc2, s, l), an) -> let s = get_ocaml_type_path s an in `Name (s, List.map map_expr l) | `Tvar (loc, s) -> `Tvar s and map_variant (x : variant) : ocaml_variant = match x with `Inherit _ -> assert false | `Variant (loc, (s, an), o) -> let s = get_ocaml_cons s an in (s, omap map_expr o, Ag_doc.get_doc loc an) and map_field ocaml_field_prefix (x : field) : ocaml_field = match x with `Inherit _ -> assert false | `Field (loc, (atd_fname, fkind, an), x) -> let ocaml_fname = get_ocaml_fname (ocaml_field_prefix ^ atd_fname) an in let fname = if ocaml_fname = atd_fname then ocaml_fname else sprintf "%s (*atd %s *)" ocaml_fname atd_fname in let is_mutable = get_ocaml_mutable an in ((fname, is_mutable), map_expr x, Ag_doc.get_doc loc an) let map_def ~(target : target) ~(type_aliases : string option) ((loc, (s, param, an1), x) : type_def) : ocaml_def option = let is_predef = get_ocaml_predef target an1 in let is_abstract = Ag_mapping.is_abstract x in let define_alias = if is_predef || is_abstract || type_aliases <> None then match get_ocaml_module_and_t target s an1, type_aliases with Some (types_module, main_module, s), _ -> Some (types_module, s) | None, Some types_module -> Some (types_module, s) | None, None -> None else None in if is_predef && define_alias = None then None else let an2 = Atd_ast.annot_of_type_expr x in let an = an1 @ an2 in let doc = Ag_doc.get_doc loc an in let alias, x = match define_alias with None -> if is_abstract then (None, None) else (None, Some (map_expr x)) | Some (module_path, ext_name) -> let alias = Some (module_path ^ "." ^ ext_name, param) in let x = match map_expr x with `Sum (`Classic, _) | `Record (`Record, _) as x -> Some x | _ -> None in (alias, x) in if x = None && alias = None then None else Some { o_def_name = (s, param); o_def_alias = alias; o_def_expr = x; o_def_doc = doc } let rec select f = function [] -> [] | x :: l -> match f x with None -> select f l | Some y -> y :: select f l let map_module ~target ~type_aliases (l : module_body) : ocaml_module_body = select ( fun (`Type td) -> match map_def ~target ~type_aliases td with None -> None | Some x -> Some (`Type x) ) l (* Mapping from Ag_mapping to OCaml *) let rec ocaml_of_expr_mapping (x : (atd_ocaml_repr, _) mapping) : ocaml_expr = match x with `Unit (loc, `Unit, _) -> `Name ("unit", []) | `Bool (loc, `Bool, _) -> `Name ("bool", []) | `Int (loc, `Int x, _) -> `Name (string_of_ocaml_int x, []) | `Float (loc, `Float, _) -> `Name ("float", []) | `String (loc, `String, _) -> `Name ("string", []) | `Sum (loc, a, `Sum kind, _) -> let l = Array.to_list a in `Sum (kind, List.map ocaml_of_variant_mapping l) | `Record (loc, a, `Record o, _) -> let l = Array.to_list a in `Record (`Record, List.map ocaml_of_field_mapping l) | `Tuple (loc, a, o, _) -> let l = Array.to_list a in `Tuple (List.map (fun x -> ocaml_of_expr_mapping x.cel_value) l) | `List (loc, x, `List kind, _) -> `Name (string_of_ocaml_list kind, [ocaml_of_expr_mapping x]) | `Option (loc, x, `Option, _) -> `Name ("option", [ocaml_of_expr_mapping x]) | `Nullable (loc, x, `Nullable, _) -> `Name ("option", [ocaml_of_expr_mapping x]) | `Wrap _ -> assert false | `Name (loc, s, l, _, _) -> `Name (s, List.map ocaml_of_expr_mapping l) | `Tvar (loc, s) -> `Tvar s | _ -> assert false and ocaml_of_variant_mapping x = let o = match x.var_arepr with `Variant o -> o | _ -> assert false in (o.ocaml_cons, omap ocaml_of_expr_mapping x.var_arg, o.ocaml_vdoc) and ocaml_of_field_mapping x = let o = match x.f_arepr with `Field o -> o | _ -> assert false in let v = ocaml_of_expr_mapping x.f_value in ((o.ocaml_fname, o.ocaml_mutable), v, o.ocaml_fdoc) (* Pretty-printing *) let rlist = { list with wrap_body = `Force_breaks; indent_body = 0; align_closing = false; space_after_opening = false; space_before_closing = false } let plist = { list with align_closing = false; space_after_opening = false; space_before_closing = false } let hlist = { list with wrap_body = `No_breaks } let shlist = { hlist with stick_to_label = false; space_after_opening = false; space_before_closing = false } let shlist0 = { shlist with space_after_separator = false } let llist = { list with separators_stick_left = false; space_before_separator = true; space_after_separator = true } let lplist = { llist with space_after_opening = false; space_before_closing = false } let vseq = { list with indent_body = 0; wrap_body = `Force_breaks; } let vlist1 = { list with stick_to_label = false } let vlist = { vlist1 with wrap_body = `Force_breaks; } let label0 = { label with space_after_label = false } let make_atom s = Atom (s, atom) let horizontal_sequence l = List (("", "", "", shlist), l) let horizontal_sequence0 l = List (("", "", "", shlist0), l) let rec insert sep = function [] | [_] as l -> l | x :: l -> x :: sep @ insert sep l let rec insert2 f = function [] | [_] as l -> l | x :: (y :: _ as l) -> x :: f x y @ insert2 f l let vertical_sequence ?(skip_lines = 0) l = let l = if skip_lines = 0 then l else let sep = Array.to_list (Array.init skip_lines (fun _ -> (Atom ("", atom)))) in insert sep l in List (("", "", "", rlist), l) let escape f s = let buf = Buffer.create (2 * String.length s) in for i = 0 to String.length s - 1 do let c = s.[i] in match f c with None -> Buffer.add_char buf c | Some s -> Buffer.add_string buf s done; Buffer.contents buf let ocamldoc_escape s = let esc = function '{' | '}' | '[' | ']' | '@' | '\\' as c -> Some (sprintf "\\%c" c) | _ -> None in escape esc s let ocamldoc_verbatim_escape s = let esc = function '{' | '}' | '\\' as c -> Some (sprintf "\\%c" c) | _ -> None in escape esc s let split = Str.split (Str.regexp " ") let make_ocamldoc_block = function `Pre s -> Atom ("\n{v\n" ^ ocamldoc_verbatim_escape s ^ "\nv}", atom) | `Before_paragraph -> Atom ("", atom) | `Paragraph l -> let l = List.map ( function `Text s -> ocamldoc_escape s | `Code s -> "[" ^ ocamldoc_escape s ^ "]" ) l in let words = split (String.concat "" l) in let atoms = List.map (fun s -> Atom (s, atom)) words in List (("", "", "", plist), atoms) let make_ocamldoc_blocks (l : Ag_doc.block list) = let l = insert2 ( fun x y -> match y with `Paragraph _ -> [`Before_paragraph] | `Pre _ -> [] | _ -> assert false ) (l :> [ Ag_doc.block | `Before_paragraph ] list) in List.map make_ocamldoc_block l let make_ocamldoc_comment (`Text l) = let blocks = make_ocamldoc_blocks l in let xlist = match l with [] | [_] -> vlist1 | _ -> vlist in List (("(**", "", "*)", xlist), blocks) let prepend_ocamldoc_comment doc x = match doc with None -> x | Some y -> let comment = make_ocamldoc_comment y in List (("", "", "", rlist), [comment;x]) let append_ocamldoc_comment x doc = match doc with None -> x | Some y -> let comment = make_ocamldoc_comment y in Label ((x, label), comment) let format_pp_conv_node node = function | `Camlp4 [] | `Ppx [] -> node | converters -> let converters = match converters with | `Ppx cs -> "[@@deriving " ^ (String.concat ", " cs) ^ "]" | `Camlp4 cs -> "with " ^ (String.concat ", " cs) in Label ((node, label), make_atom converters) let rec format_module_item pp_convs is_first (`Type def : ocaml_module_item) = let type_ = if is_first then "type" else "and" in let s, param = def.o_def_name in let alias = def.o_def_alias in let expr = def.o_def_expr in let doc = def.o_def_doc in let append_if b s1 s2 = if b then s1 ^ s2 else s1 in let part1 = horizontal_sequence ( make_atom type_ :: prepend_type_param param [ make_atom (append_if (alias <> None || expr <> None) s " =") ] ) in let part12 = match alias with None -> part1 | Some (name, param) -> let right = horizontal_sequence ( prepend_type_param param [ make_atom (append_if (expr <> None) name " =") ] ) in Label ( (part1, label), right ) in let part123 = match expr with None -> part12 | Some t -> Label ( (part12, label), format_type_expr t ) in format_pp_conv_node (prepend_ocamldoc_comment doc part123) pp_convs and prepend_type_param l tl = match l with [] -> tl | _ -> let make_var s = make_atom ("'" ^ s) in let x = match l with [s] -> make_var s | l -> List (("(", ",", ")", plist), List.map make_var l) in x :: tl and prepend_type_args l tl = match l with [] -> tl | _ -> let x = match l with [t] -> format_type_expr t | l -> List (("(", ",", ")", plist), List.map format_type_expr l) in x :: tl and format_type_expr x = match x with `Sum (kind, l) -> let op, cl = match kind with `Classic -> "", "" | `Poly -> "[", "]" in List ( (op, "|", cl, llist), List.map (format_variant kind) l ) | `Record (kind, l) -> let op, cl = match kind with `Record -> "{", "}" | `Object -> "<", ">" in List ( (op, ";", cl, list), List.map format_field l ) | `Tuple l -> List ( ("(", "*", ")", lplist), List.map format_type_expr l ) | `Name (name, args) -> format_type_name name args | `Tvar name -> make_atom ("'" ^ name) and format_type_name name args = horizontal_sequence (prepend_type_args args [ make_atom name ]) and format_field ((s, is_mutable), t, doc) = let l = let l = [make_atom (s ^ ":")] in if is_mutable then make_atom "mutable" :: l else l in let field = Label ( (horizontal_sequence l, label), format_type_expr t ) in append_ocamldoc_comment field doc and format_variant kind (s, o, doc) = let s = match kind with `Classic -> s | `Poly -> "`" ^ s in let cons = make_atom s in let variant = match o with None -> cons | Some t -> Label ( (cons, label), Label ( (make_atom "of", label), format_type_expr t ) ) in append_ocamldoc_comment variant doc let format_module_items pp_convs is_rec (l : ocaml_module_body) = match l with x :: l -> format_module_item pp_convs true x :: List.map (fun x -> format_module_item pp_convs false x) l | [] -> [] let format_module_bodies pp_conv (l : (bool * ocaml_module_body) list) = List.flatten (List.map (fun (is_rec, x) -> format_module_items pp_conv is_rec x) l) let format_head (loc, an) = match Ag_doc.get_doc loc an with None -> [] | Some doc -> [make_ocamldoc_comment doc] let format_all l = vertical_sequence ~skip_lines:1 l let ocaml_of_expr x : string = Easy_format.Pretty.to_string (format_type_expr x) let ocaml_of_atd ?(pp_convs=`Ppx []) ~target ~type_aliases (head, (l : (bool * module_body) list)) : string = let head = format_head head in let bodies = List.map (fun (is_rec, m) -> (is_rec, map_module ~target ~type_aliases m)) l in let body = format_module_bodies pp_convs bodies in let x = format_all (head @ body) in Easy_format.Pretty.to_string x let unwrap_option deref x = match deref x with `Option (_, x, _, _) | `Nullable (_, x, _, _) -> x | `Name (loc, s, _, _, _) -> Ag_error.error loc ("Not an option type: " ^ s) | x -> Ag_error.error (loc_of_mapping x) "Not an option type" let get_implicit_ocaml_default deref x = match deref x with `Unit (loc, `Unit, _) -> Some "()" | `Bool (loc, `Bool, _) -> Some "false" | `Int (loc, `Int o, _) -> Some (match o with `Int -> "0" | `Char -> "'\000'" | `Int32 -> "0l" | `Int64 -> "0L" | `Float -> "0.") | `Float (loc, `Float, _) -> Some "0.0" | `String (loc, `String, _) -> Some "\"\"" | `List (loc, x, `List `List, _) -> Some "[]" | `List (loc, x, `List `Array, _) -> Some "[||]" | `Option (loc, x, `Option, _) -> Some "None" | `Nullable (loc, x, `Nullable, _) -> Some "None" | _ -> None let map_record_creator_field deref x = let o = match x.f_arepr with `Field o -> o | _ -> assert false in let fname = o.ocaml_fname in let impl2 = sprintf "\n %s = %s;" fname fname in match x.f_kind with `Required -> let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in let intf = sprintf "\n %s: %s ->" fname t in let impl1 = sprintf "\n ~%s" fname in intf, impl1, impl2 | `Optional -> let x = unwrap_option deref x.f_value in let t = ocaml_of_expr (ocaml_of_expr_mapping x) in let intf = sprintf "\n ?%s: %s ->" fname t in let impl1 = sprintf "\n ?%s" fname in intf, impl1, impl2 | `With_default -> let t = ocaml_of_expr (ocaml_of_expr_mapping x.f_value) in let intf = sprintf "\n ?%s: %s ->" fname t in let impl1 = let default = match o.ocaml_default with None -> (match get_implicit_ocaml_default deref x.f_value with None -> Ag_error.error x.f_loc "Missing default field value" | Some s -> s ) | Some s -> s in sprintf "\n ?(%s = %s)" fname default in intf, impl1, impl2 atdgen-1.9.1/src/ag_oj_emit.ml000066400000000000000000001527441273120334000162120ustar00rootroot00000000000000(* OCaml code generator for the json format. *) open Printf open Atd_ast open Ag_error open Ag_mapping open Ag_oj_mapping (* OCaml code generator (json readers and writers) *) let name_of_var s = "_" ^ s type param = { deref : (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.mapping -> (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.mapping; std : bool; unknown_field_handler : string option; (* Optional handler that takes a field name as argument and does something with it such as displaying a warning message. *) constr_mismatch_handler : string option; (* Optional handler that takes a constructor field name, a constructor field value, a value field name, and a value field value as arguments and does something with it such as displaying a warning message. *) force_defaults : bool; preprocess_input : string option; (* intended for UTF-8 validation *) ocaml_version: (int * int) option; } let make_ocaml_json_intf ~with_create buf deref defs = List.iter ( fun x -> let s = x.def_name in if s <> "" && s.[0] <> '_' && x.def_value <> None then ( let full_name = Ag_ox_emit.get_full_type_name x in let writer_params = String.concat "" ( List.map (fun s -> sprintf "\n (Bi_outbuf.t -> '%s -> unit) ->" s) x.def_param ) in let reader_params = String.concat "" ( List.map (fun s -> sprintf "\n (Yojson.Safe.lexer_state -> \ Lexing.lexbuf -> '%s) ->" s) x.def_param ) in bprintf buf "\ val write_%s :%s Bi_outbuf.t -> %s -> unit (** Output a JSON value of type {!%s}. *) " s writer_params full_name s; bprintf buf "\ val string_of_%s :%s ?len:int -> %s -> string (** Serialize a value of type {!%s} into a JSON string. @param len specifies the initial length of the buffer used internally. Default: 1024. *) " s writer_params full_name s; bprintf buf "\ val read_%s :%s Yojson.Safe.lexer_state -> Lexing.lexbuf -> %s (** Input JSON data of type {!%s}. *) " s reader_params full_name s; bprintf buf "\ val %s_of_string :%s string -> %s (** Deserialize JSON data of type {!%s}. *) " s reader_params full_name s; if with_create && Ag_ox_emit.is_exportable x then let create_record_intf, create_record_impl = Ag_ox_emit.make_record_creator deref x in bprintf buf "%s" create_record_intf; bprintf buf "\n"; ) ) (flatten defs) let is_json_string deref x = (* Calling 'unwrap' allows us to ignore 'wrap' constructors and determine that the JSON representation is a string. This assumes that no '' annotation imposes another representation for the JSON string. *) match Ag_mapping.unwrap deref x with | `String _ -> true | _ -> false (* or maybe we just don't know *) let get_assoc_type deref loc x = match deref x with | `Tuple (loc2, [| k; v |], `Tuple, `Tuple) -> if not (is_json_string deref k.cel_value) then error loc "Due to keys must be strings"; (k.cel_value, v.cel_value) | _ -> error loc "Expected due to : (string * _) list" let nth name i len = let l = Array.to_list (Array.init len (fun j -> if i = j then name else "_")) in String.concat ", " l type default_field = | Default of string | Checked of int type parse_field = { mapping : (o, j) field_mapping; default : default_field; ocamlf : Ag_ocaml.atd_ocaml_field; jsonf : Ag_json.json_field; field_ref : string; constructor : int option; payloads : int list; implicit : bool; } (* identifiers can't begin with digits *) let implicit_field_name jname = "0jic_"^jname let get_fields p a = let k, acc = Array.fold_left (fun (k,acc) (i, x) -> let ocamlf, default, jsonf, k = match x.f_arepr, x.f_brepr with `Field o, `Field j -> (match x.f_kind with `With_default -> (match o.Ag_ocaml.ocaml_default with None -> let d = Ag_ocaml.get_implicit_ocaml_default p.deref x.f_value in (match d with | None -> error x.f_loc "Missing default field value" | Some d -> o, Default d, j, k) | Some d -> o, Default d, j, k ) | `Optional -> o, Default "None", j, k | `Required -> o, Checked k, j, k+1 ) | _ -> assert false in let field_ref = "field_"^ocamlf.Ag_ocaml.ocaml_fname in let constructor = None in let payloads = [] in k, { mapping=x; default; ocamlf; jsonf; field_ref; constructor; payloads; implicit=false; }::acc ) (0,[]) (Array.mapi (fun i x -> (i, x)) a) in let fc = List.length acc in let fm = Hashtbl.create fc in let jfdir = Hashtbl.create fc in let neg_one = List.fold_left (fun n f -> Hashtbl.replace fm n f; Hashtbl.replace jfdir f.jsonf.Ag_json.json_fname n; n - 1 ) (fc - 1) acc in assert (neg_one = -1); let existing_constr constr = try Some (Hashtbl.find jfdir constr) with Not_found -> None in (* Add implicit fields and index the deconstructed/tag field relations *) let _k = Hashtbl.fold (fun i { jsonf = {Ag_json.json_tag_field} } k -> match json_tag_field with | None -> k | Some constr -> let field = Hashtbl.find fm i in match existing_constr constr with | Some c_i -> let consf = Hashtbl.find fm c_i in Hashtbl.replace fm i { field with constructor = Some c_i }; Hashtbl.replace fm c_i { consf with payloads = i::consf.payloads }; k | None -> (* Synthesize implicit field *) let c_i = Hashtbl.length fm in let f_name = implicit_field_name constr in let ocamlf = { Ag_ocaml.ocaml_fname = f_name; ocaml_default = None; ocaml_mutable = false; ocaml_fdoc = None; } in let jsonf = { Ag_json.json_fname = constr; json_tag_field = None; json_unwrapped = false; } in let synloc = (Lexing.dummy_pos, Lexing.dummy_pos) in let mapping = { f_loc = synloc; f_name = f_name; f_kind = `Required; f_value = `String (synloc, `String, `String); f_arepr = `Field ocamlf; f_brepr = `Field jsonf; } in let imp = { mapping = mapping; default = Checked k; ocamlf = ocamlf; jsonf = jsonf; field_ref = "field_"^f_name; constructor = None; payloads = [i]; implicit = true; } in Hashtbl.replace fm i { field with constructor = Some c_i }; Hashtbl.replace fm c_i imp; Hashtbl.replace jfdir constr c_i; k ) (Hashtbl.copy fm) k in let a = Array.make (Hashtbl.length fm) (Hashtbl.find fm 0) in Array.iteri (fun n _ -> a.(n) <- Hashtbl.find fm n) a; a let insert sep l = let rec ins sep = function [] -> [] | x :: l -> sep :: x :: ins sep l in match l with [] -> [] | x :: l -> x :: ins sep l let make_json_string s = Yojson.Safe.to_string (`String s) let unopt = function None -> assert false | Some x -> x (* ('a, 'b) t -> write_t write__a write__b ('a, foo) t -> write_t write__a write_foo ('a, (foo, 'b) bar) t -> write_t write__a (write_bar write_foo write__b) *) let rec get_writer_name ?(paren = false) ?(name_f = fun s -> "write_" ^ s) p (x : oj_mapping) : string = match x with `Unit (loc, `Unit, `Unit) -> "Yojson.Safe.write_null" | `Bool (loc, `Bool, `Bool) -> "Yojson.Safe.write_bool" | `Int (loc, `Int o, `Int) -> (match o with `Int -> "Yojson.Safe.write_int" | `Char -> "Ag_oj_run.write_int8" | `Int32 -> "Ag_oj_run.write_int32" | `Int64 -> "Ag_oj_run.write_int64" | `Float -> "Ag_oj_run.write_float_as_int" ) | `Float (loc, `Float, `Float j) -> (match j with `Float None -> if p.std then "Yojson.Safe.write_std_float" else "Yojson.Safe.write_float" | `Float (Some precision) -> if p.std then sprintf "Yojson.Safe.write_std_float_prec %i" precision else sprintf "Yojson.Safe.write_float_prec %i" precision | `Int -> "Ag_oj_run.write_float_as_int" ) | `String (loc, `String, `String) -> "Yojson.Safe.write_string" | `Tvar (loc, s) -> "write_" ^ name_of_var s | `Name (loc, s, args, None, None) -> let l = List.map (get_writer_name ~paren:true p) args in let s = String.concat " " (name_f s :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | `External (loc, s, args, `External (types_module, main_module, ext_name), `External) -> let f = main_module ^ "." ^ name_f ext_name in let l = List.map (get_writer_name ~paren:true p) args in let s = String.concat " " (f :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | _ -> assert false let get_left_writer_name p name param = let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_writer_name p (`Name (dummy_loc, name, args, None, None)) let get_left_to_string_name p name param = let name_f s = "string_of_" ^ s in let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_writer_name ~name_f p (`Name (dummy_loc, name, args, None, None)) let rec get_reader_name ?(paren = false) ?(name_f = fun s -> "read_" ^ s) p (x : oj_mapping) : string = match x with `Unit (loc, `Unit, `Unit) -> "Ag_oj_run.read_null" | `Bool (loc, `Bool, `Bool) -> "Ag_oj_run.read_bool" | `Int (loc, `Int o, `Int) -> (match o with `Int -> "Ag_oj_run.read_int" | `Char -> "Ag_oj_run.read_int8" | `Int32 -> "Ag_oj_run.read_int32" | `Int64 -> "Ag_oj_run.read_int64" | `Float -> "Ag_oj_run.read_number" ) | `Float (loc, `Float, `Float j) -> "Ag_oj_run.read_number" | `String (loc, `String, `String) -> "Ag_oj_run.read_string" | `Tvar (loc, s) -> "read_" ^ name_of_var s | `Name (loc, s, args, None, None) -> let l = List.map (get_reader_name ~paren:true p) args in let s = String.concat " " (name_f s :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | `External (loc, s, args, `External (types_module, main_module, ext_name), `External) -> let f = main_module ^ "." ^ name_f ext_name in let l = List.map (get_reader_name ~paren:true p) args in let s = String.concat " " (f :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s | _ -> assert false let get_left_reader_name p name param = let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_reader_name p (`Name (dummy_loc, name, args, None, None)) let get_left_of_string_name p name param = let name_f s = s ^ "_of_string" in let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_reader_name ~name_f p (`Name (dummy_loc, name, args, None, None)) let destruct_sum (x : oj_mapping) = match x with `Sum (loc, a, `Sum x, `Sum) -> let tick = match x with `Classic -> "" | `Poly -> "`" in tick, a | `Unit _ -> error (loc_of_mapping x) "Cannot destruct unit" | `Bool _ -> error (loc_of_mapping x) "Cannot destruct bool" | `Int _ -> error (loc_of_mapping x) "Cannot destruct int" | `Float _ -> error (loc_of_mapping x) "Cannot destruct float" | `String _ -> error (loc_of_mapping x) "Cannot destruct string" | `Name (_,name,_,_,_) -> error (loc_of_mapping x) ("Cannot destruct name " ^ name) | `External _ -> error (loc_of_mapping x) "Cannot destruct external" | `Tvar _ -> error (loc_of_mapping x) "Cannot destruct tvar" | `Record _ -> error (loc_of_mapping x) "Cannot destruct record" | `Tuple _ -> error (loc_of_mapping x) "Cannot destruct tuple" | `List _ -> error (loc_of_mapping x) "Cannot destruct list" | `Option _ -> error (loc_of_mapping x) "Cannot destruct option" | `Nullable _ -> error (loc_of_mapping x) "Cannot destruct nullable" | `Wrap _ -> error (loc_of_mapping x) "Cannot destruct wrap" | _ -> error (loc_of_mapping x) "Cannot destruct unknown type" let make_sum_writer p sum f = let tick, a = destruct_sum (p.deref sum) in let cases = Array.to_list (Array.map (fun x -> let o, j = match x.var_arepr, x.var_brepr with `Variant o, `Variant j -> o, j | _ -> assert false in `Inline (f p tick o j x)) a ) in let body : Ag_indent.t list = [ `Line "match sum with"; `Block cases; ] in [ `Annot ("fun", `Line "fun ob sum ->"); `Block body ] let is_optional = function | { default=Default _ } -> true | { default=Checked _ } -> false let unwrap p { jsonf=jsonf; mapping=mapping } = if jsonf.Ag_json.json_unwrapped then Ag_ocaml.unwrap_option p.deref mapping.f_value else mapping.f_value let string_expr_of_constr_field p v_of_field field = let v = v_of_field field in let f_value = unwrap p field in match f_value with `String _ -> [ `Line v ] | _ -> ( `Line "(" ):: (make_sum_writer p f_value (fun p tick o j x -> let ocaml_cons = o.Ag_ocaml.ocaml_cons in let json_cons = j.Ag_json.json_cons in match x.var_arg with None -> [ `Line (sprintf "| %s%s -> %S" tick ocaml_cons json_cons); ] | Some _ -> [ `Line (sprintf "| %s%s _ -> %S" tick ocaml_cons json_cons); ] ))@[ `Line (sprintf ") () %s" v)] let rec make_writer p (x : oj_mapping) : Ag_indent.t list = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ | `Name _ | `External _ | `Tvar _ -> [ `Line (get_writer_name p x) ] | `Sum _ -> make_sum_writer p x make_variant_writer | `Record (loc, a, `Record o, `Record) -> [ `Annot ("fun", `Line "fun ob x ->"); `Block (make_record_writer p a o); ] | `Tuple (loc, a, `Tuple, `Tuple) -> let len = Array.length a in let a = Array.mapi ( fun i x -> `Inline [ `Line (sprintf "(let %s = x in" (nth "x" i len)); `Line "("; `Block (make_writer p x.cel_value); `Line ") ob x"; `Line ");" ] ) a in let l = insert (`Line "Bi_outbuf.add_char ob ',';") (Array.to_list a) in let op, cl = if p.std then '[', ']' else '(', ')' in [ `Annot ("fun", `Line "fun ob x ->"); `Block [ `Line (sprintf "Bi_outbuf.add_char ob %C;" op); `Inline l; `Line (sprintf "Bi_outbuf.add_char ob %C;" cl); ] ] | `List (loc, x, `List o, `List j) -> (match j with `Array -> let write = match o with `List -> "Ag_oj_run.write_list (" | `Array -> "Ag_oj_run.write_array (" in [ `Line write; `Block (make_writer p x); `Line ")"; ] | `Object -> let k, v = get_assoc_type p.deref loc x in let write = match o with `List -> "Ag_oj_run.write_assoc_list (" | `Array -> "Ag_oj_run.write_assoc_array (" in [ `Line write; `Block (make_writer p k); `Line ") ("; `Block (make_writer p v); `Line ")"; ] ) | `Option (loc, x, `Option, `Option) -> [ `Line (sprintf "Ag_oj_run.write_%soption (" (if p.std then "std_" else "")); `Block (make_writer p x); `Line ")"; ] | `Nullable (loc, x, `Nullable, `Nullable) -> [ `Line "Ag_oj_run.write_nullable ("; `Block (make_writer p x); `Line ")"; ] | `Wrap (loc, x, `Wrap o, `Wrap) -> (match o with None -> make_writer p x | Some { Ag_ocaml.ocaml_wrap_t; ocaml_wrap; ocaml_unwrap } -> [ `Line "fun ob x -> ("; `Block [ `Line (sprintf "let x = ( %s ) x in (" ocaml_unwrap); `Block (make_writer p x); `Line ") ob x)"; ] ] ) | _ -> assert false and make_variant_writer p tick o j x : Ag_indent.t list = let ocaml_cons = o.Ag_ocaml.ocaml_cons in let json_cons = j.Ag_json.json_cons in match x.var_arg with None -> let enclose s = if p.std then s else "<" ^ s ^ ">" in [ `Line (sprintf "| %s%s -> Bi_outbuf.add_string ob %S" tick ocaml_cons (enclose (make_json_string json_cons))) ] | Some v -> let op, sep, cl = if p.std then "[", ",", ']' else "<", ":", '>' in [ `Line (sprintf "| %s%s x ->" tick ocaml_cons); `Block [ `Line (sprintf "Bi_outbuf.add_string ob %S;" (op ^ make_json_string json_cons ^ sep)); `Line "("; `Block (make_writer p v); `Line ") ob x;"; `Line (sprintf "Bi_outbuf.add_char ob %C" cl); ] ] and make_deconstructed_writer f g p tick o j x : Ag_indent.t list = let ocaml_cons = o.Ag_ocaml.ocaml_cons in let json_cons = j.Ag_json.json_cons in match x.var_arg with None -> [ `Line (sprintf "| %s%s ->" tick ocaml_cons); (g json_cons) ] | Some v -> [ `Line (sprintf "| %s%s deconstr ->" tick ocaml_cons); (g json_cons); f (`Block [ `Line "("; `Block (make_writer p v); `Line ") ob deconstr;"; ]) ] and make_record_writer p a record_kind = let fields = get_fields p a in let sep = [ `Line "if !is_first then"; `Block [ `Line "is_first := false" ]; `Line "else"; `Block [ `Line "Bi_outbuf.add_char ob ',';"; ]; ] in let write_field_tag json_fname = sprintf "Bi_outbuf.add_string ob %S;" (make_json_string json_fname ^ ":") in let v_of_field field = let dot = match record_kind with | `Record -> "." | `Object -> "#" in let ocaml_fname = field.ocamlf.Ag_ocaml.ocaml_fname in if is_optional field then sprintf "x.%s" ocaml_fname else sprintf "x%s%s" dot ocaml_fname in let apply p f field = let v = v_of_field field in if field.jsonf.Ag_json.json_unwrapped then [ `Line (sprintf "(match %s with None -> () | Some x ->" v); `Block (f "x"); `Line ");" ] else match field.default with | Checked _ -> f v | Default _ when p.force_defaults -> f v | Default d -> [ `Line (sprintf "if %s <> %s then (" v d); `Block (f v); `Line ");" ] in let constr_var constr = "constr_" ^ constr.mapping.f_name in let write_constr_ss = Array.map (function | { payloads = payload_i :: _ } as field -> `Inline [ `Line (sprintf "let %s =" (constr_var field)); `Block (string_expr_of_constr_field p v_of_field (if field.implicit then fields.(payload_i) else field)); `Line "in"; ] | { payloads = [] } -> `Inline [] ) fields in let v_or_constr v field = if field.implicit then constr_var field else v in let write_fields = Array.mapi ( fun i field -> let json_fname = field.jsonf.Ag_json.json_fname in let app v = let f_value = unwrap p field in match field with | { constructor = Some constr_i } -> let constr = fields.(constr_i) in let cons_code json_cons = (* Tag will be written. Check equality. *) `Block (apply p (fun v -> [ `Line (sprintf "if %s <> %S then" (constr_var constr) json_cons); (match p.constr_mismatch_handler with None -> `Line "();" | Some f -> `Line (sprintf "(%s) %S %s %S %S;" f (v_of_field constr) (constr_var constr) (v_of_field field) json_cons)); ] ) field) in ( `Line "(" ):: (make_sum_writer p f_value (make_deconstructed_writer (fun write_deconstr -> `Block [ `Inline sep; `Line (write_field_tag json_fname); write_deconstr; ] ) cons_code) )@[ `Line (sprintf ") ob %s;" (v_or_constr v field)) ] | { constructor = None } -> [ `Inline sep; `Line (write_field_tag json_fname); `Line "("; `Block (make_writer p f_value); `Line ")"; `Block [`Line (sprintf "ob %s;" (v_or_constr v field))] ] in `Inline (apply p app field) ) fields in [ `Line "Bi_outbuf.add_char ob '{';"; `Line "let is_first = ref true in"; `Inline (Array.to_list write_constr_ss); `Inline (Array.to_list write_fields); `Line "Bi_outbuf.add_char ob '}';"; ] let study_record p fields = let unset_field_value = match p.ocaml_version with | Some (maj, min) when (maj > 4 || maj = 4 && min >= 3) -> "Obj.magic (Sys.opaque_identity 0.0)" | _ -> "Obj.magic 0.0" in let _, field_assignments = Array.fold_right (fun field (i, field_assignments) -> let v = match field.default with | Checked _ -> unset_field_value | Default s -> s in let field_ref = field.field_ref in let init_f = `Line (sprintf "let %s = ref (%s) in" field_ref v) in let init = match field.constructor with | None -> init_f | Some _constr_i -> let oname = field.ocamlf.Ag_ocaml.ocaml_fname in `Inline [ (* prepare to defer parsing *) init_f; `Line (sprintf "let raw_%s = (" oname); `Line "Yojson.init_lexer ~lnum:(-1) ()"; `Line ") in"; ] in let create = if field.implicit then `Block [] (* implicit fields don't have realizations in OCaml *) else let oname = field.ocamlf.Ag_ocaml.ocaml_fname in `Line (sprintf "%s = !field_%s;" oname oname) in (i + 1, (init, create) :: field_assignments) ) fields (0,[]) in let init_fields, create_record_fields = List.split field_assignments in let create_record = [ `Line "{"; `Block create_record_fields; `Line "}" ] in let n = Array.fold_left (fun n -> function | { default = Checked k } -> max n (k + 1) | { default = Default _ } -> n ) 0 fields in let k = n / 31 + (if n mod 31 > 0 then 1 else 0) in let init_bits = Array.to_list ( Array.init k ( fun i -> `Line (sprintf "let bits%i = ref 0 in" i) ) ) in let final_bits = Array.make k 0 in for z = 0 to n - 1 do let i = z / 31 in let j = z mod 31 in final_bits.(i) <- final_bits.(i) lor (1 lsl j); done; let set_bit z = let i = z / 31 in let j = z mod 31 in `Line (sprintf "bits%i := !bits%i lor 0x%x;" i i (1 lsl j)) in let check_bits = let bool_expr = String.concat " || " ( Array.to_list ( Array.mapi ( fun i x -> sprintf "!bits%i <> 0x%x" i x ) final_bits ) ) in let bit_fields = let a = Array.init k (fun i -> sprintf "!bits%i" i) in sprintf "[| %s |]" (String.concat "; " (Array.to_list a)) in let field_names = let _, l = Array.fold_left ( fun (i,acc) field -> match field.default with | Checked k -> assert (k = i); (i + 1, sprintf "%S" field.mapping.f_name :: acc) | Default _ -> (i,acc) ) (0,[]) fields in sprintf "[| %s |]" (String.concat "; " (List.rev l)) in if k = 0 then [] else [ `Line (sprintf "if %s then Ag_oj_run.missing_fields p %s %s;" bool_expr bit_fields field_names) ] in init_fields, init_bits, set_bit, check_bits, create_record let rec make_reader p type_annot (x : oj_mapping) : Ag_indent.t list = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ | `Name _ | `External _ | `Tvar _ -> [ `Line (get_reader_name p x) ] | `Sum (loc, a, `Sum x, `Sum) -> let tick = match x with `Classic -> "" | `Poly -> "`" in let cases = Array.to_list ( Array.map (make_variant_reader p type_annot tick false) a ) in let l0, l1 = List.partition (fun x -> x.var_arg = None) (Array.to_list a) in let cases0 = List.map (make_variant_reader p type_annot tick true) l0 in let cases1 = List.map (make_variant_reader p type_annot tick true) l1 in let error_expr1 = [ `Line "Ag_oj_run.invalid_variant_tag p (String.sub s pos len)" ] in let int_mapping_function, int_matching = Ag_string_match.make_ocaml_int_mapping ~error_expr1 cases in let std_int_mapping_function0, std_int_matching0 = Ag_string_match.make_ocaml_int_mapping ~error_expr1 cases0 in let std_int_mapping_function1, std_int_matching1 = Ag_string_match.make_ocaml_int_mapping ~error_expr1 cases1 in let read_tag = [ `Line "Yojson.Safe.read_space p lb;"; `Line "match Yojson.Safe.start_any_variant p lb with"; `Block [ `Line "| `Edgy_bracket -> ("; `Block [ `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "let f ="; `Block int_mapping_function; `Line "in"; `Line "let i = Yojson.Safe.map_ident p f lb in"; `Inline int_matching; ]; `Line ")"; ]; `Line "| `Double_quote -> ("; `Block [ `Block [ `Line "let f ="; `Block std_int_mapping_function0; `Line "in"; `Line "let i = Yojson.Safe.map_string p f lb in"; `Inline std_int_matching0; ]; `Line ")"; ]; `Line "| `Square_bracket -> ("; `Block [ `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "let f ="; `Block std_int_mapping_function1; `Line "in"; `Line "let i = Yojson.Safe.map_ident p f lb in"; `Inline std_int_matching1; ]; `Line ")"; ]; ]; ] in [ `Annot ("fun", `Line "fun p lb ->"); `Block [ `Inline read_tag; ] ] | `Record (loc, a, `Record o, `Record) -> (match o with `Record -> () | `Object -> error loc "Sorry, OCaml objects are not supported" ); [ `Annot ("fun", `Line "fun p lb ->"); `Block (make_record_reader p type_annot loc a o) ] | `Tuple (loc, a, `Tuple, `Tuple) -> [ `Annot ("fun", `Line "fun p lb ->"); `Block (make_tuple_reader p a); ] | `List (loc, x, `List o, `List j) -> (match j with `Array -> let read = match o with `List -> "Ag_oj_run.read_list (" | `Array -> "Ag_oj_run.read_array (" in [ `Line read; `Block (make_reader p None x); `Line ")"; ] | `Object -> let k, v = get_assoc_type p.deref loc x in let read = match o with `List -> "Ag_oj_run.read_assoc_list (" | `Array -> "Ag_oj_run.read_assoc_array (" in [ `Line read; `Block (make_reader p None k); `Line ") ("; `Block (make_reader p None v); `Line ")"; ] ) | `Option (loc, x, `Option, `Option) -> let a = [| { var_loc = loc; var_cons = "None"; var_arg = None; var_arepr = `Variant { Ag_ocaml.ocaml_cons = "None"; ocaml_vdoc = None }; var_brepr = `Variant { Ag_json.json_cons = "None" }; }; { var_loc = loc; var_cons = "Some"; var_arg = Some x; var_arepr = `Variant { Ag_ocaml.ocaml_cons = "Some"; ocaml_vdoc = None }; var_brepr = `Variant { Ag_json.json_cons = "Some" }; }; |] in make_reader p (Some "_ option") (`Sum (loc, a, `Sum `Classic, `Sum)) | `Nullable (loc, x, `Nullable, `Nullable) -> [ `Line "fun p lb ->"; `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "(if Yojson.Safe.read_null_if_possible p lb then None"; `Line "else Some (("; `Block (make_reader p None x); `Line ") p lb) : _ option)" ] ] | `Wrap (loc, x, `Wrap o, `Wrap) -> (match o with None -> make_reader p type_annot x | Some { Ag_ocaml.ocaml_wrap_t; ocaml_wrap; ocaml_unwrap } -> [ `Line "fun p lb ->"; `Block [ `Line "let x = ("; `Block (make_reader p type_annot x); `Line ") p lb in"; `Line (sprintf "( %s ) x" ocaml_wrap); ] ] ) | _ -> assert false and make_variant_reader p type_annot tick std x : (string * Ag_indent.t list) = let o, j = match x.var_arepr, x.var_brepr with `Variant o, `Variant j -> o, j | _ -> assert false in let ocaml_cons = o.Ag_ocaml.ocaml_cons in let json_cons = j.Ag_json.json_cons in let expr = match x.var_arg with None -> if std then [ `Line (Ag_ox_emit.opt_annot type_annot (sprintf "%s%s" tick ocaml_cons)); ] else [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_gt p lb;"; `Line (Ag_ox_emit.opt_annot type_annot (sprintf "%s%s" tick ocaml_cons)); ] | Some v -> if std then [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_comma p lb;"; `Line "Yojson.Safe.read_space p lb;"; `Line "let x = ("; `Block [ `Block (make_reader p None v); `Line ") p lb"; ]; `Line "in"; `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_rbr p lb;"; `Line (Ag_ox_emit.opt_annot type_annot (sprintf "%s%s x" tick ocaml_cons)); ] else [ `Line "Ag_oj_run.read_until_field_value p lb;"; `Line "let x = ("; `Block [ `Block (make_reader p None v); `Line ") p lb"; ]; `Line "in"; `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_gt p lb;"; `Line (Ag_ox_emit.opt_annot type_annot (sprintf "%s%s x" tick ocaml_cons)); ] in (json_cons, expr) and make_deconstructed_reader p loc fields set_bit = let v_of_field field = "!" ^ field.field_ref in let reconstruct_field constrf payloadf = let ocaml_name = payloadf.ocamlf.Ag_ocaml.ocaml_fname in let mapping = payloadf.mapping in let set_bit = match payloadf.default with | Default _ -> [] | Checked k -> [set_bit k] in match p.deref mapping.f_value with | `Sum (loc, a, `Sum x, `Sum) -> let s = string_expr_of_constr_field p v_of_field constrf in let tick = match x with `Classic -> "" | `Poly -> "`" in let cases = Array.to_list ( Array.map (fun x -> let o, j = match x.var_arepr, x.var_brepr with `Variant o, `Variant j -> o, j | _ -> assert false in let ocaml_cons = o.Ag_ocaml.ocaml_cons in let json_cons = j.Ag_json.json_cons in let expr = match x.var_arg with | None -> [ `Line (sprintf "let loc = raw_%s in" ocaml_name); `Line "if loc.Yojson.lnum <> -1"; `Line "then ("; (* TODO: should this be a different warning/error? *) (match p.unknown_field_handler with None -> `Line "();" | Some f -> `Line (sprintf "(%s) %S %S;" f (Atd_ast.string_of_loc loc) mapping.f_name)); `Line (sprintf "%s := %s%s" payloadf.field_ref tick ocaml_cons); `Line ") else ("; `Inline set_bit; `Line (sprintf "%s := %s%s);" payloadf.field_ref tick ocaml_cons); ] | Some v -> [ `Line (sprintf "let loc = raw_%s in" ocaml_name); `Line "if loc.Yojson.lnum <> -1"; `Line "then (let raw = Bi_outbuf.contents loc.Yojson.buf in"; `Line "Bi_outbuf.clear loc.Yojson.buf;"; `Line "let lb = Lexing.from_string raw in"; `Line "let x = ("; `Block [ `Block (make_reader p None v); `Line ") loc lb"; ]; `Line "in"; `Line (sprintf "%s := %s%s x);" payloadf.field_ref tick ocaml_cons); ] in (json_cons, expr) ) a) in let error_expr1 = [ `Line "Ag_oj_run.invalid_variant_tag p s" ] in let int_mapping_function, int_matching = Ag_string_match.make_ocaml_int_mapping ~error_expr1 cases in [ `Line "let s = ("; `Block s; `Line ") in"; `Line "let f = ("; `Block int_mapping_function; `Line ") in"; `Line "let i = f s 0 (String.length s) in ("; `Block int_matching; `Line ");"; `Line "let constr ="; `Inline (string_expr_of_constr_field p v_of_field payloadf); `Line "in if s <> constr"; (match p.constr_mismatch_handler with None -> `Line "then ()" | Some f -> `Line (sprintf "then (%s) %S %s %S %s;" f constrf.mapping.f_name "s" mapping.f_name "constr")); ] | _ -> (* reconstructing a non-sum, undefined *) error loc "can't reconstruct a non-sum" in let rec toposort_fields order = function | [] -> if List.length order = Array.length fields then order else error loc "recursive constructors not allowed" | n::s -> toposort_fields (n::order) (List.rev_append fields.(n).payloads s) in let toposorted_fields = toposort_fields [] (fst (Array.fold_left (fun (s, i) -> function | { constructor = None } -> (i :: s, i + 1) | { constructor = Some _ } -> (s, i + 1) ) ([], 0) fields)) in List.fold_left (fun updates i -> let field = fields.(i) in match field.constructor with | None -> updates | Some constr_i -> let constr = fields.(constr_i) in match constr.default with | Default _ -> (`Block [ `Line "("; `Block (reconstruct_field constr field); `Line ");"; ])::updates | Checked k -> let i = k / 31 in let j = 1 lsl (k mod 31) in (`Block [ `Line (sprintf "if !bits%i land 0x%x = 0x%x" i j j); `Line "then ("; `Block (reconstruct_field constr field); `Line ")"; match field.default with | Default _ when constr.implicit -> `Block [ `Line "else ("; set_bit k; `Line ");"; ] | Default _ | Checked _ -> `Line ";" ])::updates ) [] toposorted_fields and make_record_reader p type_annot loc a record_kind = let fields = get_fields p a in let init_fields, init_bits, set_bit, check_bits, create_record = study_record p fields in let read_field = let cases = Array.mapi (fun i field -> let { ocamlf = ocamlf; jsonf = jsonf; mapping = x } = field in let unwrapped = jsonf.Ag_json.json_unwrapped in let f_value = if unwrapped then Ag_ocaml.unwrap_option p.deref x.f_value else x.f_value in let wrap l = if unwrapped then [ `Line "Some ("; `Block l; `Line ")" ] else l in let read_value = [ `Line "("; `Block (make_reader p None f_value); `Line ") p lb"; ] in let ocaml_fname = ocamlf.Ag_ocaml.ocaml_fname in let expr = match jsonf.Ag_json.json_tag_field with | Some _ -> [ (* Defer parsing until we have read the whole record including the constructor tag. *) `Line (sprintf "(let loc = raw_%s in" ocaml_fname); `Line "let cnum = lb.Lexing.lex_curr_pos in"; `Line "loc.Yojson.lnum <- p.Yojson.lnum;"; `Line "loc.Yojson.bol <- p.Yojson.bol - cnum;"; `Line "loc.Yojson.fname <- p.Yojson.fname;"; `Line "Bi_outbuf.clear p.Yojson.buf;"; `Line "Yojson.Safe.buffer_json p lb;"; `Line "let raw = Bi_outbuf.contents p.Yojson.buf in"; `Line "Bi_outbuf.clear p.Yojson.buf;"; `Line "Bi_outbuf.clear loc.Yojson.buf;"; `Line "Bi_outbuf.add_string loc.Yojson.buf raw"; `Line ");"; match field.default with | Checked k -> set_bit k | Default _ -> `Inline [] ] | None -> [ `Line (sprintf "field_%s := (" ocaml_fname); `Block (wrap read_value); `Line ");"; match field.default with | Checked k -> set_bit k | Default _ -> `Inline [] ] in let opt_expr = match field.default with | Default _ -> [ `Line "if not (Yojson.Safe.read_null_if_possible p lb) then ("; `Block expr; `Line ")" ] | Checked _ -> expr in (jsonf.Ag_json.json_fname, opt_expr) ) fields in let int_mapping_function, int_matching = let error_expr1 = match p.unknown_field_handler with None -> [ `Line "-1" ] | Some f -> [ `Line (sprintf "(%s) %S (String.sub s pos len); -1" f (Atd_ast.string_of_loc loc)) ] in Ag_string_match.make_ocaml_int_mapping ~exit_with: `Expr ~error_expr1 ~error_expr2: [ `Line "Yojson.Safe.skip_json p lb" ] (Array.to_list cases) in [ `Line "Yojson.Safe.read_space p lb;"; `Line "let f ="; `Block int_mapping_function; `Line "in"; `Line "let i = Yojson.Safe.map_ident p f lb in"; `Line "Ag_oj_run.read_until_field_value p lb;"; `Line "("; `Block int_matching; `Line ");"; ] in let update_deconstructed_fields = if List.exists (function | { constructor = Some _ } -> true | { constructor = None } -> false ) (Array.to_list fields) then make_deconstructed_reader p loc fields set_bit else [] in [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_lcurl p lb;"; `Inline init_fields; `Inline init_bits; `Line "try"; `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_object_end lb;"; `Inline read_field; `Line "while true do"; `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_object_sep p lb;"; `Inline read_field; ]; `Line "done;"; `Line "assert false;"; ]; `Line "with Yojson.End_of_object -> ("; `Block [ `Block [ `Inline update_deconstructed_fields; `Inline check_bits; `Line "("; `Block create_record; `Line (sprintf "%s)" (Ag_ox_emit.insert_annot type_annot)); ]; `Line ")"; ]; ] and make_tuple_reader p a = let cells = Array.map ( fun x -> match x.cel_arepr with `Cell f -> x, f.Ag_ocaml.ocaml_default | _ -> assert false ) a in let min_length = let n = ref (Array.length cells) in (try for i = Array.length cells - 1 downto 0 do let x, default = cells.(i) in if default = None then ( n := i + 1; raise Exit ) done with Exit -> ()); !n in let read_cells = List.flatten ( Array.to_list ( Array.mapi ( fun i (x, default) -> let read_value = [ `Line "("; `Block (make_reader p None x.cel_value); `Line ") p lb"; ] in let get_value = if i < min_length - 1 then [ `Line "let x ="; `Block read_value; `Line "in"; `Line "incr len;"; `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_tuple_sep2 p std_tuple lb;"; `Line "x" ] else if i = min_length - 1 then [ `Line "let x ="; `Block read_value; `Line "in"; `Line "incr len;"; `Line "(try"; `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_tuple_sep2 p std_tuple lb;"; ]; `Line "with Yojson.End_of_tuple -> end_of_tuple := true);"; `Line "x" ] else let default_value = match default with None -> assert false | Some s -> s in [ `Line (sprintf "if !end_of_tuple then (%s)" default_value); `Line "else ("; `Block [ `Line "let x = ("; `Block read_value; `Line ") in"; `Line "incr len;"; `Line "(try"; `Block [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_tuple_sep2 p std_tuple lb;"; ]; `Line "with Yojson.End_of_tuple ->"; `Block [ `Line "end_of_tuple := true);"; ]; `Line "x"; ]; `Line ")"; ] in [ `Line (sprintf "let x%i =" i); `Block get_value; `Line "in"; ] ) cells ) ) in let make_tuple = sprintf "(%s)" (String.concat ", " (Array.to_list (Array.mapi (fun i _ -> sprintf "x%i" i) a))) in let req_fields = let acc = ref [] in for i = Array.length cells - 1 downto 0 do let _, default = cells.(i) in if default = None then acc := string_of_int i :: !acc done; sprintf "[ %s ]" (String.concat "; " !acc) in let finish_empty_tuple = if min_length = 0 then [ `Line "(try Yojson.Safe.read_tuple_end2 p std_tuple lb"; `Line "with Yojson.End_of_tuple -> end_of_tuple := true)"; ] else [] in let skip_remaining_cells = [ `Line "if not !end_of_tuple then ("; `Block [ `Line "try"; `Block [ `Line "while true do"; `Block [ `Line "Yojson.Safe.skip_json p lb;"; `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_tuple_sep2 p std_tuple lb;"; ]; `Line "done"; ]; `Line "with Yojson.End_of_tuple -> ()"; ]; `Line ");" ] in [ `Line "Yojson.Safe.read_space p lb;"; `Line "let std_tuple = Yojson.Safe.start_any_tuple p lb in"; `Line "let len = ref 0 in"; `Line "let end_of_tuple = ref false in"; `Inline finish_empty_tuple; `Line "(try"; `Block [ `Inline read_cells; `Inline skip_remaining_cells; `Line make_tuple; ]; `Line "with Yojson.End_of_tuple ->"; `Block [ `Line (sprintf "Ag_oj_run.missing_tuple_fields p !len %s);" req_fields); ]; ] let make_ocaml_json_writer p ~original_types is_rec let1 let2 def = let x = match def.def_value with None -> assert false | Some x -> x in let name = def.def_name in let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in let param = def.def_param in let write = get_left_writer_name p name param in let to_string = get_left_to_string_name p name param in let writer_expr = make_writer p x in let eta_expand = is_rec && not (Ag_ox_emit.is_function writer_expr) in let needs_annot = Ag_ox_emit.needs_type_annot x in let extra_param, extra_args, type_annot = match eta_expand, needs_annot with | true, false -> " ob x", " ob x", None | true, true -> sprintf " ob (x : %s)" type_constraint, " ob x", None | false, false -> "", "", None | false, true -> "", "", Some (sprintf "_ -> %s -> _" type_constraint) in [ `Line (sprintf "%s %s = (" let1 (Ag_ox_emit.opt_annot_def type_annot (write ^ extra_param))); `Block (List.map Ag_indent.strip writer_expr); `Line (sprintf ")%s" extra_args); `Line (sprintf "%s %s ?(len = 1024) x =" let2 to_string); `Block [ `Line "let ob = Bi_outbuf.create len in"; `Line (sprintf "%s ob x;" write); `Line "Bi_outbuf.contents ob" ] ] let make_ocaml_json_reader p ~original_types is_rec let1 let2 def = let x = match def.def_value with None -> assert false | Some x -> x in let name = def.def_name in let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in let param = def.def_param in let read = get_left_reader_name p name param in let of_string = get_left_of_string_name p name param in let type_annot = match Ag_ox_emit.needs_type_annot x with | true -> Some type_constraint | false -> None in let reader_expr = make_reader p type_annot x in let eta_expand = is_rec && not (Ag_ox_emit.is_function reader_expr) in let extra_param, extra_args = if eta_expand then " p lb", " p lb" else "", "" in let pp = match p.preprocess_input with None -> [] | Some f -> [ `Line (sprintf "let s = ( %s ) s in" f) ] in [ `Line (sprintf "%s %s%s = (" let1 read extra_param); `Block (List.map Ag_indent.strip reader_expr); `Line (sprintf ")%s" extra_args); `Line (sprintf "%s %s s =" let2 of_string); `Block [ `Inline pp; `Line ( sprintf "%s (Yojson.Safe.init_lexer ()) \ (Lexing.from_string s)" read); ] ] let map f = function [] -> [] | x :: l -> let y = f true x in y :: List.map (f false) l let get_let ~is_rec ~is_first = if is_first then if is_rec then "let rec", "and" else "let", "let" else "and", "and" let make_ocaml_json_impl ~std ~unknown_field_handler ~constr_mismatch_handler ~with_create ~force_defaults ~preprocess_input ~original_types ~ocaml_version buf deref defs = let p = { deref = deref; std = std; unknown_field_handler = unknown_field_handler; constr_mismatch_handler = constr_mismatch_handler; force_defaults = force_defaults; preprocess_input; ocaml_version; } in let ll = List.map ( fun (is_rec, l) -> let l = List.filter (fun x -> x.def_value <> None) l in let writers = map ( fun is_first def -> let let1, let2 = get_let ~is_rec ~is_first in make_ocaml_json_writer p ~original_types is_rec let1 let2 def ) l in let readers = map ( fun is_first def -> let let1, let2 = get_let ~is_rec ~is_first in make_ocaml_json_reader p ~original_types is_rec let1 let2 def ) l in List.flatten (writers @ readers) ) defs in Atd_indent.to_buffer buf (List.flatten ll); if with_create then List.iter ( fun (is_rec, l) -> let l = List.filter Ag_ox_emit.is_exportable l in List.iter ( fun x -> let intf, impl = Ag_ox_emit.make_record_creator deref x in Buffer.add_string buf impl ) l ) defs (* Glue *) let translate_mapping (l : (bool * Atd_ast.module_body) list) = defs_of_atd_modules l let write_opens buf l = List.iter (fun s -> bprintf buf "open %s\n" s) l; bprintf buf "\n" let make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_json_intf ~with_create buf deref defs; Buffer.contents buf let make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~std ~unknown_field_handler ~constr_mismatch_handler ~force_defaults ~preprocess_input ~original_types ~ocaml_version ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_json_impl ~std ~unknown_field_handler ~constr_mismatch_handler ~with_create ~force_defaults ~preprocess_input ~original_types ~ocaml_version buf deref defs; Buffer.contents buf let make_ocaml_files ~opens ~with_typedefs ~with_create ~with_fundefs ~all_rec ~std ~unknown_field_handler ~constr_mismatch_handler ~pos_fname ~pos_lnum ~type_aliases ~force_defaults ~preprocess_input ~name_overlap ~ocaml_version ~pp_convs atd_file out = let ((head, m0), _) = match atd_file with Some file -> Atd_util.load_file ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum file | None -> Atd_util.read_channel ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum stdin in let tsort = if all_rec then function m -> [ (true, m) ] else Atd_util.tsort in let m1 = tsort m0 in let defs1 = translate_mapping m1 in if not name_overlap then Ag_ox_emit.check defs1; let (m1', original_types) = Atd_expand.expand_module_body ~keep_poly:true m0 in let m2 = tsort m1' in (* m0 = original type definitions m1 = original type definitions after dependency analysis m2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = Ag_ocaml.ocaml_of_atd ~pp_convs ~target:`Json ~type_aliases (head, m1) in let defs = translate_mapping m2 in let header = let src = match atd_file with None -> "stdin" | Some path -> sprintf "%S" (Filename.basename path) in sprintf "(* Auto-generated from %s *)\n" src in let mli = make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs (Ag_mapping.make_deref defs1) defs1 in let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~std ~unknown_field_handler ~constr_mismatch_handler ~force_defaults ~preprocess_input ~original_types ~ocaml_version ocaml_typedefs (Ag_mapping.make_deref defs) defs in Ag_ox_emit.write_ocaml out mli ml atdgen-1.9.1/src/ag_oj_mapping.ml000066400000000000000000000141121273120334000166710ustar00rootroot00000000000000open Printf open Atd_ast open Ag_error open Ag_mapping type o = Ag_ocaml.atd_ocaml_repr type j = Ag_json.json_repr type oj_mapping = (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.mapping type oj_def = (Ag_ocaml.atd_ocaml_repr, Ag_json.json_repr) Ag_mapping.def (* Translation of the types into the ocaml/json mapping. *) let rec mapping_of_expr (x : type_expr) : oj_mapping = match x with `Sum (loc, l, an) -> let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in let json_t = `Sum in `Sum (loc, Array.of_list (List.map mapping_of_variant l), ocaml_t, json_t) | `Record (loc, l, an) -> let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in let json_t = `Record in `Record (loc, Array.of_list (List.map (mapping_of_field ocaml_field_prefix) l), ocaml_t, json_t) | `Tuple (loc, l, an) -> let ocaml_t = `Tuple in let json_t = `Tuple in `Tuple (loc, Array.of_list (List.map mapping_of_cell l), ocaml_t, json_t) | `List (loc, x, an) -> let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in let json_t = `List (Ag_json.get_json_list an) in `List (loc, mapping_of_expr x, ocaml_t, json_t) | `Option (loc, x, an) -> let ocaml_t = `Option in let json_t = `Option in `Option (loc, mapping_of_expr x, ocaml_t, json_t) | `Nullable (loc, x, an) -> let ocaml_t = `Nullable in let json_t = `Nullable in `Nullable (loc, mapping_of_expr x, ocaml_t, json_t) | `Shared (loc, x, an) -> error loc "Sharing is not supported by the JSON interface" | `Wrap (loc, x, an) -> let ocaml_t = `Wrap (Ag_ocaml.get_ocaml_wrap loc an) in let json_t = `Wrap in `Wrap (loc, mapping_of_expr x, ocaml_t, json_t) | `Name (loc, (loc2, s, l), an) -> (match s with "unit" -> `Unit (loc, `Unit, `Unit) | "bool" -> `Bool (loc, `Bool, `Bool) | "int" -> let o = Ag_ocaml.get_ocaml_int an in `Int (loc, `Int o, `Int) | "float" -> let j = Ag_json.get_json_float an in `Float (loc, `Float, `Float j) | "string" -> `String (loc, `String, `String) | s -> `Name (loc, s, List.map mapping_of_expr l, None, None) ) | `Tvar (loc, s) -> `Tvar (loc, s) and mapping_of_cell (loc, x, an) = let default = Ag_ocaml.get_ocaml_default an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Cell { Ag_ocaml.ocaml_default = default; ocaml_fname = ""; ocaml_mutable = false; ocaml_fdoc = doc; } in let json_t = `Cell in { cel_loc = loc; cel_value = mapping_of_expr x; cel_arepr = ocaml_t; cel_brepr = json_t } and mapping_of_variant = function `Variant (loc, (s, an), o) -> let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Variant { Ag_ocaml.ocaml_cons = ocaml_cons; ocaml_vdoc = doc; } in let json_cons = Ag_json.get_json_cons s an in let json_t = `Variant { Ag_json.json_cons = json_cons; } in let arg = match o with None -> None | Some x -> Some (mapping_of_expr x) in { var_loc = loc; var_cons = s; var_arg = arg; var_arepr = ocaml_t; var_brepr = json_t } | `Inherit _ -> assert false and mapping_of_field ocaml_field_prefix = function `Field (loc, (s, fk, an), x) -> let fvalue = mapping_of_expr x in let ocaml_default, json_unwrapped = match fk, Ag_ocaml.get_ocaml_default an with `Required, None -> None, false | `Optional, None -> Some "None", true | (`Required | `Optional), Some _ -> error loc "Superfluous default OCaml value" | `With_default, Some s -> Some s, false | `With_default, None -> (* will try to determine implicit default value later *) None, false in let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in let doc = Ag_doc.get_doc loc an in let json_fname = Ag_json.get_json_fname s an in let json_tag_field = Ag_json.get_json_tag_field an in { f_loc = loc; f_name = s; f_kind = fk; f_value = fvalue; f_arepr = `Field { Ag_ocaml.ocaml_default = ocaml_default; ocaml_fname = ocaml_fname; ocaml_mutable = ocaml_mutable; ocaml_fdoc = doc; }; f_brepr = `Field { Ag_json.json_fname = json_fname; json_tag_field = json_tag_field; json_unwrapped = json_unwrapped }; } | `Inherit _ -> assert false let def_of_atd (loc, (name, param, an), x) = let ocaml_predef = Ag_ocaml.get_ocaml_predef `Json an in let doc = Ag_doc.get_doc loc an in let o = match as_abstract x with Some (loc2, an2) -> (match Ag_ocaml.get_ocaml_module_and_t `Json name an with None -> None | Some (types_module, main_module, ext_name) -> let args = List.map (fun s -> `Tvar (loc, s)) param in Some (`External (loc, name, args, `External (types_module, main_module, ext_name), `External)) ) | None -> Some (mapping_of_expr x) in { def_loc = loc; def_name = name; def_param = param; def_value = o; def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; ocaml_ddoc = doc }; def_brepr = `Def; } let defs_of_atd_module l = List.map (function `Type def -> def_of_atd def) l let defs_of_atd_modules l = List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module l)) l atdgen-1.9.1/src/ag_oj_run.ml000066400000000000000000000137561273120334000160570ustar00rootroot00000000000000(* Runtime library for JSON *) open Printf exception Error of string (* Error messages *) let error s = raise (Error s) let error_with_line p s = let s2 = match p.Yojson.Lexer_state.fname with Some f -> sprintf "File %s, line %i:\n%s" f p.Yojson.Lexer_state.lnum s | None -> sprintf "Line %i:\n%s" p.Yojson.Lexer_state.lnum s in raise (Error s2) let list_iter f sep x l = let rec aux f sep x = function [] -> () | y :: l -> sep x; f x y; aux f sep x l in match l with [] -> () | y :: l -> f x y; aux f sep x l let array_iter f sep x a = let n = Array.length a in if n > 0 then ( f x (Array.unsafe_get a 0); for i = 1 to n - 1 do sep x; f x (Array.unsafe_get a i) done ) let write_comma ob = Bi_outbuf.add_char ob ',' let write_list write_item ob l = Bi_outbuf.add_char ob '['; list_iter write_item write_comma ob l; Bi_outbuf.add_char ob ']' let write_array write_item ob a = Bi_outbuf.add_char ob '['; array_iter write_item write_comma ob a; Bi_outbuf.add_char ob ']' let write_assoc_list write_key write_item ob l = Bi_outbuf.add_char ob '{'; list_iter ( fun ob (k, v) -> write_key ob k; Bi_outbuf.add_char ob ':'; write_item ob v ) write_comma ob l; Bi_outbuf.add_char ob '}' let write_assoc_array write_key write_item ob l = Bi_outbuf.add_char ob '{'; array_iter ( fun ob (k, v) -> write_key ob k; Bi_outbuf.add_char ob ':'; write_item ob v ) write_comma ob l; Bi_outbuf.add_char ob '}' let write_option write_item ob = function None -> Bi_outbuf.add_string ob "<\"None\">" | Some x -> Bi_outbuf.add_string ob "<\"Some\":"; write_item ob x; Bi_outbuf.add_string ob ">" let write_std_option write_item ob = function None -> Bi_outbuf.add_string ob "\"None\"" | Some x -> Bi_outbuf.add_string ob "[\"Some\","; write_item ob x; Bi_outbuf.add_string ob "]" let write_nullable write_item ob = function None -> Bi_outbuf.add_string ob "null" | Some x -> write_item ob x let write_int8 ob x = Yojson.Safe.write_int ob (int_of_char x) let write_int32 ob x = Bi_outbuf.add_string ob (Int32.to_string x) let write_int64 ob x = Bi_outbuf.add_string ob (Int64.to_string x) let min_float = float min_int let max_float = float max_int let write_float_as_int ob x = if x >= min_float && x <= max_float then Yojson.Safe.write_int ob (int_of_float (if x < 0. then x -. 0.5 else x +. 0.5)) else match classify_float x with FP_normal | FP_subnormal | FP_zero -> Bi_outbuf.add_string ob (Printf.sprintf "%.0f" x) | FP_infinite -> error "Cannot convert inf or -inf into a JSON int" | FP_nan -> error "Cannot convert NaN into a JSON int" let read_null p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_null p lb let read_bool p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_bool p lb let read_int p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_int p lb let read_int8 p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_int8 p lb let read_int32 p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_int32 p lb let read_int64 p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_int64 p lb let read_number p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_number p lb let read_string p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_string p lb let read_list read_item p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_list read_item p lb let read_array read_item p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_array read_item p lb let read_assoc_list_rev read_key read_item p lb = Yojson.Safe.read_space p lb; let read acc k p lb = (k, read_item p lb) :: acc in Yojson.Safe.read_abstract_fields read_key read [] p lb let read_assoc_list read_key read_item p lb = List.rev (read_assoc_list_rev read_key read_item p lb) let array_of_rev_list l = match l with [] -> [| |] | x :: tl -> let len = List.length l in let a = Array.make len x in let r = ref tl in for i = len - 2 downto 0 do a.(i) <- List.hd !r; r := List.tl !r done; a let read_assoc_array read_key read_item p lb = array_of_rev_list (read_assoc_list_rev read_key read_item p lb) let read_until_field_value p lb = Yojson.Safe.read_space p lb; Yojson.Safe.read_colon p lb; Yojson.Safe.read_space p lb let missing_tuple_fields p len req_fields = let missing = List.fold_right ( fun i acc -> if i >= len then i :: acc else acc ) req_fields [] in error_with_line p (sprintf "Missing tuple field%s %s" (if List.length missing > 1 then "s" else "") (String.concat ", " (List.map string_of_int missing))) let missing_fields p bit_fields field_names = let acc = ref [] in for z = Array.length field_names - 1 downto 0 do let i = z / 31 in let j = z mod 31 in if bit_fields.(i) land (1 lsl j) = 0 then acc := field_names.(z) :: !acc done; error_with_line p (sprintf "Missing record field%s %s" (if List.length !acc > 1 then "s" else "") (String.concat ", " !acc)) let invalid_variant_tag p s = error_with_line p (sprintf "Unsupported variant %S" s) (* We want an identity function that is not inlined *) type identity_t = { mutable _identity : 'a. 'a -> 'a } let identity_ref = { _identity = (fun x -> x) } let identity x = identity_ref._identity x (* Checking at runtime that our assumptions on unspecified compiler behavior still hold. *) type t = { _a : int option; _b : int; } let create () = { { _a = None; _b = Array.length Sys.argv } with _a = None } let test () = let r = create () in let v = Some 17 in Obj.set_field (Obj.repr r) 0 (Obj.repr v); let safe_r = identity r in (* r._a is inlined by ocamlopt and equals None because the field is supposed to be immutable. *) assert (safe_r._a = v) let () = test () (************************************) atdgen-1.9.1/src/ag_ov_emit.ml000066400000000000000000000336531273120334000162230ustar00rootroot00000000000000(* Validators of OCaml data whose types are defined using ATD. *) open Printf open Atd_ast open Ag_error open Ag_mapping open Ag_ov_mapping let name_of_var s = "_" ^ s let make_ocaml_validate_intf ~with_create buf deref defs = List.iter ( fun x -> if with_create && Ag_ox_emit.is_exportable x then ( let create_record_intf, create_record_impl = Ag_ox_emit.make_record_creator deref x in bprintf buf "%s" create_record_intf; ); let full_name = Ag_ox_emit.get_full_type_name x in let validator_params = String.concat "" ( List.map (fun s -> sprintf "\n (Ag_util.Validation.path -> '%s -> \ Ag_util.Validation.error option) ->" s) x.def_param ) in let s = x.def_name in if Ag_ox_emit.is_exportable x then ( bprintf buf "\ val validate_%s :%s Ag_util.Validation.path -> %s -> Ag_util.Validation.error option (** Validate a value of type {!%s}. *) " s validator_params full_name s ) ) (flatten defs) let nth name i len = let l = Array.to_list (Array.init len (fun j -> if i = j then name else "_")) in String.concat ", " l let get_fields a = let all = List.map ( fun x -> match x.f_arepr with `Field o -> (x, o.Ag_ocaml.ocaml_fname) | _ -> assert false ) (Array.to_list a) in List.filter ( function { f_brepr = (None, shallow) }, name -> not shallow | _ -> assert false ) all let rec forall : Ag_indent.t list -> Ag_indent.t list = function | [] -> [] | [x] -> [x] | x :: l -> [ `Line "match"; `Block [x]; `Line "with"; `Block [ `Line "| Some _ as err -> err"; `Line "| None ->"; `Block (forall l); ] ] let unopt = function None -> assert false | Some x -> x let return_true = "fun _ _ -> None" let return_true_paren = "(fun _ _ -> None)" let opt_validator_name = function None -> return_true_paren | Some s -> sprintf "( %s )" s let opt_validator = function None -> [ `Line "fun _ _ -> None" ] | Some s -> [ `Line s ] let opt_validator_s = function None -> "(fun _ _ -> None)" | Some s -> sprintf "( %s )" s let prepend_validator opt l = match opt with None -> l | Some s -> [ `Line (sprintf "match ( %s ) path x with" s); `Block [ `Line "| Some _ as err -> err"; `Line "| None ->"; `Block l; ] ] let prepend_validator_s v s2 = match v with None -> s2 | Some s1 -> sprintf "(fun path x -> \ match ( %s ) path x with \ | Some _ as err -> err \ | None -> (%s) path x)" s1 s2 let prepend_validator_f v l = match v with None -> l | Some s -> [ `Line "(fun path x ->"; `Block [ `Line (sprintf "(match ( %s ) path x with" s); `Block [ `Line "| Some _ as err -> err"; `Line "| None -> ("; `Block [ `Block l; `Line ") path x"; ] ]; `Line ")"; ]; `Line ")"; ] (* ('a, 'b) t -> validate_t validate__a validate__b ('a, foo) t -> validate_t validate__a validate_foo ('a, (foo, 'b) bar) t -> validate_t validate__a (validate_bar validate_foo validate__b) *) let rec get_validator_name ?(paren = false) ?(name_f = fun s -> "validate_" ^ s) (x : ov_mapping) : string = match x with `Unit (loc, `Unit, v) | `Bool (loc, `Bool, v) | `Int (loc, `Int _, v) | `Float (loc, `Float, v) | `String (loc, `String, v) -> (match v with (None, true) -> return_true_paren | (Some s, true) -> s | (_, false) -> assert false ) | `Tvar (loc, s) -> "validate_" ^ name_of_var s | `Name (loc, s, args, None, opt) -> let v1 = let l = List.map (get_validator_name ~paren:true) args in let s = String.concat " " (name_f s :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s in (match opt with None -> v1 | Some (o, false) -> prepend_validator_s o v1 | Some (o, true) -> opt_validator_s o ) | `External (loc, s, args, `External (types_module, main_module, ext_name), v) -> (match v with (o, false) -> prepend_validator_s o ( let f = main_module ^ "." ^ name_f ext_name in let l = List.map (get_validator_name ~paren:true) args in let s = String.concat " " (f :: l) in if paren && l <> [] then "(" ^ s ^ ")" else s ) | (_, true) -> assert false ) | _ -> assert false let get_left_validator_name name param = let args = List.map (fun s -> `Tvar (dummy_loc, s)) param in get_validator_name (`Name (dummy_loc, name, args, None, None)) let rec make_validator (x : ov_mapping) : Ag_indent.t list = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ | `Name _ | `External _ | `Tvar _ -> [ `Line (get_validator_name x) ] | `Sum (loc, a, `Sum x, (v, shallow)) -> if shallow then opt_validator v else let tick = match x with `Classic -> "" | `Poly -> "`" in let body : Ag_indent.t list = [ `Line "match x with"; `Block ( Array.to_list ( Array.map (fun x -> `Inline (make_variant_validator tick x)) a ) ) ] in [ `Annot ("fun", `Line "fun path x ->"); `Block (prepend_validator v body); ] | `Record (loc, a, `Record o, (v, shallow)) -> if shallow then opt_validator v else [ `Annot ("fun", `Line "fun path x ->"); `Block (prepend_validator v (make_record_validator a o)); ] | `Tuple (loc, a, `Tuple, (v, shallow)) -> if shallow then opt_validator v else let len = Array.length a in let l = Array.to_list (Array.mapi (fun i x -> (i, x)) a) in let l = List.filter (fun (i, x) -> not (snd x.cel_brepr)) l in let l = List.map ( fun (i, x) -> `Inline [ `Line (sprintf "(let %s = x in" (nth "x" i len)); `Line "("; `Block (make_validator x.cel_value); `Line (sprintf ") (`Index %i :: path) x" i); `Line ")" ] ) l in let l = forall l in [ `Annot ("fun", `Line "fun path x ->"); `Block (prepend_validator v l); ] | `List (loc, x, `List o, (v, shallow)) -> if shallow then opt_validator v else let validate = match o with `List -> "Ag_ov_run.validate_list (" | `Array -> "Ag_ov_run.validate_array (" in prepend_validator_f v [ `Line validate; `Block (make_validator x); `Line ")"; ] | `Option (loc, x, `Option, (v, shallow)) | `Nullable (loc, x, `Nullable, (v, shallow)) -> if shallow then opt_validator v else prepend_validator_f v [ `Line "Ag_ov_run.validate_option ("; `Block (make_validator x); `Line ")"; ] | `Wrap (loc, x, `Wrap o, (v, shallow)) -> if shallow then opt_validator v else prepend_validator_f v (make_validator x) | _ -> assert false and make_variant_validator tick x : Ag_indent.t list = let o = match x.var_arepr, x.var_brepr with `Variant o, (None, _) -> o | _ -> assert false in let ocaml_cons = o.Ag_ocaml.ocaml_cons in match x.var_arg with None -> [ `Line (sprintf "| %s%s -> None" tick ocaml_cons) ] | Some v -> [ `Line (sprintf "| %s%s x ->" tick ocaml_cons); `Block [ `Line "("; `Block (make_validator v); `Line ") path x" ] ] and make_record_validator a record_kind = let dot = match record_kind with `Record -> "." | `Object -> "#" in let fields = get_fields a in assert (fields <> []); let validate_fields : Ag_indent.t list = List.map ( fun (x, ocaml_fname) -> `Inline [ `Line "("; `Block (make_validator x.Ag_mapping.f_value); `Line (sprintf ") (`Field %S :: path) x%s%s" ocaml_fname dot ocaml_fname); ] ) fields in forall validate_fields let make_ocaml_validator ~original_types is_rec let1 let2 def = let x = match def.def_value with None -> assert false | Some x -> x in let name = def.def_name in let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in let param = def.def_param in let validate = get_left_validator_name name param in let validator_expr = make_validator x in let eta_expand = is_rec && not (Ag_ox_emit.is_function validator_expr) in let needs_annot = Ag_ox_emit.needs_type_annot x in let extra_param, extra_args, type_annot = match eta_expand, needs_annot with | true, false -> " path x", " path x", None | true, true -> sprintf " path (x : %s)" type_constraint, " path x", None | false, false -> "", "", None | false, true -> "", "", Some (sprintf "_ -> %s -> _" type_constraint) in [ `Line (sprintf "%s %s = (" let1 (Ag_ox_emit.opt_annot_def type_annot (validate ^ extra_param))); `Block (List.map Ag_indent.strip validator_expr); `Line (sprintf ")%s" extra_args); ] let map f = function [] -> [] | x :: l -> let y = f true x in y :: List.map (f false) l let get_let ~is_rec ~is_first = if is_first then if is_rec then "let rec", "and" else "let", "let" else "and", "and" let make_ocaml_validate_impl ~with_create ~original_types buf deref defs = let ll = List.map ( fun (is_rec, l) -> let l = List.filter (fun x -> x.def_value <> None) l in let validators = map ( fun is_first def -> let let1, let2 = get_let ~is_rec ~is_first in make_ocaml_validator ~original_types is_rec let1 let2 def ) l in List.flatten validators ) defs in Atd_indent.to_buffer buf (List.flatten ll); if with_create then List.iter ( fun (is_rec, l) -> let l = List.filter Ag_ox_emit.is_exportable l in List.iter ( fun x -> let intf, impl = Ag_ox_emit.make_record_creator deref x in Buffer.add_string buf impl ) l ) defs (* Glue *) let translate_mapping (l : (bool * Atd_ast.module_body) list) = Ag_ov_mapping.defs_of_atd_modules l let write_opens buf l = List.iter (fun s -> bprintf buf "open %s\n" s) l; bprintf buf "\n" let make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_validate_intf ~with_create buf deref defs; Buffer.contents buf let make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types ocaml_typedefs deref defs = let buf = Buffer.create 1000 in bprintf buf "%s\n" header; write_opens buf opens; if with_typedefs then bprintf buf "%s\n" ocaml_typedefs; if with_typedefs && with_fundefs then bprintf buf "\n"; if with_fundefs then make_ocaml_validate_impl ~with_create ~original_types buf deref defs; Buffer.contents buf let make_ocaml_files ~opens ~with_typedefs ~with_create ~with_fundefs ~all_rec ~pos_fname ~pos_lnum ~type_aliases ~force_defaults ~name_overlap ~ocaml_version ~pp_convs atd_file out = let ((head, m0), _) = match atd_file with Some file -> Atd_util.load_file ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum file | None -> Atd_util.read_channel ~expand:false ~inherit_fields:true ~inherit_variants:true ?pos_fname ?pos_lnum stdin in let tsort = if all_rec then function m -> [ (true, m) ] else Atd_util.tsort in let m1 = tsort m0 in let defs1 = translate_mapping m1 in if not name_overlap then Ag_ox_emit.check defs1; let (m1', original_types) = Atd_expand.expand_module_body ~keep_poly:true m0 in let m2 = tsort m1' in (* m0 = original type definitions m1 = original type definitions after dependency analysis m2 = monomorphic type definitions after dependency analysis *) let ocaml_typedefs = Ag_ocaml.ocaml_of_atd ~pp_convs ~target:`Validate ~type_aliases (head, m1) in let defs = translate_mapping m2 in let header = let src = match atd_file with None -> "stdin" | Some path -> sprintf "%S" (Filename.basename path) in sprintf "(* Auto-generated from %s *)\n" src in let mli = make_mli ~header ~opens ~with_typedefs ~with_create ~with_fundefs ocaml_typedefs (Ag_mapping.make_deref defs1) defs1 in let ml = make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types ocaml_typedefs (Ag_mapping.make_deref defs) defs in Ag_ox_emit.write_ocaml out mli ml atdgen-1.9.1/src/ag_ov_mapping.ml000066400000000000000000000242331273120334000167120ustar00rootroot00000000000000open Printf open Atd_ast open Ag_error open Ag_mapping type o = Ag_ocaml.atd_ocaml_repr type v = Ag_validate.validate_repr type ov_mapping = (Ag_ocaml.atd_ocaml_repr, Ag_validate.validate_repr) Ag_mapping.mapping type ob_def = (Ag_ocaml.atd_ocaml_repr, Ag_validate.validate_repr) Ag_mapping.def (* Determine whether a type expression does not need validation. 1. Flatten. For each type expression of interest, produce the list of all type expressions on which it depends. 2. Read annotations. If any of the type expressions has a validator annotation or if on the type expressions is abstract, then the result is false. *) let ploc x = eprintf "%s\n" (string_of_loc (loc_of_type_expr x)) let print s = eprintf "%s\n%!" s let get_def defs name : type_expr option = try Some (Hashtbl.find defs name) with Not_found -> None let noval x = let an = Atd_ast.annot_of_type_expr x in Ag_validate.get_validator an = None module H = Hashtbl.Make ( struct type t = type_expr let equal = ( == ) let hash = Hashtbl.hash end ) let for_all_children f x0 = let is_root = ref true in try Atd_ast.fold ( fun x () -> if !is_root then ( is_root := false; assert (x == x0); ) else if not (f x) then raise Exit ) x0 (); true with Exit -> false (* Return if an expression is shallow, i.e. it does not require to call a validation function other than the one possibly given by an annotation on this node. Shallow: int int { x : int } t (* where t is defined as: type t = int *) Not shallow: t (* where t is defined as: type t = int *) { x : int } 'a t t (* where t is defined as: type t = abstract *) *) let rec scan_expr (defs : (string, type_expr) Hashtbl.t) (visited : unit H.t) (results : bool H.t) (x : type_expr) : bool = if not (H.mem visited x) then ( H.add visited x (); try H.find results x with Not_found -> name_is_shallow defs visited results x && for_all_children ( fun x -> noval x && scan_expr defs visited results x ) x ) else (* neutral for the && operator *) true and name_is_shallow defs visited results x = match x with `Name (loc, (loc2, name, _), _) -> (match get_def defs name with None -> (match name with "unit" | "bool" | "int" | "float" | "string" -> true | _ -> false ) | Some x -> noval x && scan_expr defs visited results x ) | `Tvar (loc, _) -> false | _ -> (* already verified in the call to scan_expr above *) true let iter f x = Atd_ast.fold (fun x () -> f x) x () let scan_top_expr (defs : (string, type_expr) Hashtbl.t) (results : bool H.t) (x : type_expr) : unit = (* Force-scan all sub-expressions *) iter ( fun x -> if not (H.mem results x) then ( let b = scan_expr defs (H.create 10) results x in (try let b0 = H.find results x in assert (b0 = b); with Not_found -> ()); H.replace results x b ) ) x let make_is_shallow defs = let results = H.create 100 in Hashtbl.iter ( fun name x -> scan_top_expr defs results x ) defs; fun x -> try H.find results x with Not_found -> assert false (* Translation of the types into the ocaml/validate mapping. *) let rec mapping_of_expr (is_shallow : type_expr -> bool) (x0 : type_expr) : ov_mapping = let v an = Ag_validate.get_validator an in let v2 an x = (Ag_validate.get_validator an, is_shallow x) in match x0 with `Sum (loc, l, an) -> let ocaml_t = `Sum (Ag_ocaml.get_ocaml_sum an) in `Sum (loc, Array.of_list (List.map (mapping_of_variant is_shallow) l), ocaml_t, v2 an x0) | `Record (loc, l, an) -> let ocaml_t = `Record (Ag_ocaml.get_ocaml_record an) in let ocaml_field_prefix = Ag_ocaml.get_ocaml_field_prefix an in `Record (loc, Array.of_list (List.map (mapping_of_field is_shallow ocaml_field_prefix) l), ocaml_t, v2 an x0) | `Tuple (loc, l, an) -> let ocaml_t = `Tuple in `Tuple (loc, Array.of_list (List.map (mapping_of_cell is_shallow) l), ocaml_t, v2 an x0) | `List (loc, x, an) -> let ocaml_t = `List (Ag_ocaml.get_ocaml_list an) in `List (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) | `Option (loc, x, an) -> let ocaml_t = `Option in `Option (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) | `Nullable (loc, x, an) -> let ocaml_t = `Nullable in `Nullable (loc, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) | `Shared (loc, x, an) -> failwith "Sharing is not supported" | `Wrap (loc, x, an) -> let w = Ag_ocaml.get_ocaml_wrap loc an in let ocaml_t = `Wrap w in let validator = match w with None -> v2 an x0 | Some _ -> v an, true in `Wrap (loc, mapping_of_expr is_shallow x, ocaml_t, validator) | `Name (loc, (loc2, s, l), an) -> (match s with "unit" -> `Unit (loc, `Unit, (v an, true)) | "bool" -> `Bool (loc, `Bool, (v an, true)) | "int" -> let o = Ag_ocaml.get_ocaml_int an in `Int (loc, `Int o, (v an, true)) | "float" -> `Float (loc, `Float, (v an, true)) | "string" -> `String (loc, `String, (v an, true)) | s -> let validator = match v2 an x0 with None, true -> None | x -> Some x in `Name (loc, s, List.map (mapping_of_expr is_shallow) l, None, validator) ) | `Tvar (loc, s) -> `Tvar (loc, s) and mapping_of_cell is_shallow (loc, x, an) = let default = Ag_ocaml.get_ocaml_default an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Cell { Ag_ocaml.ocaml_default = default; ocaml_fname = ""; ocaml_mutable = false; ocaml_fdoc = doc; } in { cel_loc = loc; cel_value = mapping_of_expr is_shallow x; cel_arepr = ocaml_t; cel_brepr = (None, noval x && is_shallow x) } and mapping_of_variant is_shallow = function `Variant (loc, (s, an), o) -> let ocaml_cons = Ag_ocaml.get_ocaml_cons s an in let doc = Ag_doc.get_doc loc an in let ocaml_t = `Variant { Ag_ocaml.ocaml_cons = ocaml_cons; ocaml_vdoc = doc; } in let arg, validate_t = match o with None -> None, (None, true) | Some x -> (Some (mapping_of_expr is_shallow x), (None, noval x && is_shallow x)) in { var_loc = loc; var_cons = s; var_arg = arg; var_arepr = ocaml_t; var_brepr = validate_t; } | `Inherit _ -> assert false and mapping_of_field is_shallow ocaml_field_prefix = function `Field (loc, (s, fk, an), x) -> let fvalue = mapping_of_expr is_shallow x in let ocaml_default = match fk, Ag_ocaml.get_ocaml_default an with `Required, None -> None | `Optional, None -> Some "None" | (`Required | `Optional), Some _ -> error loc "Superfluous default OCaml value" | `With_default, Some s -> Some s | `With_default, None -> (* will try to determine implicit default value later *) None in let ocaml_fname = Ag_ocaml.get_ocaml_fname (ocaml_field_prefix ^ s) an in let ocaml_mutable = Ag_ocaml.get_ocaml_mutable an in let doc = Ag_doc.get_doc loc an in { f_loc = loc; f_name = s; f_kind = fk; f_value = fvalue; f_arepr = `Field { Ag_ocaml.ocaml_default = ocaml_default; ocaml_fname = ocaml_fname; ocaml_mutable = ocaml_mutable; ocaml_fdoc = doc; }; f_brepr = (None, noval x && is_shallow x); } | `Inherit _ -> assert false let def_of_atd is_shallow (loc, (name, param, an), x) = let ocaml_predef = Ag_ocaml.get_ocaml_predef `Validate an in let doc = Ag_doc.get_doc loc an in let o = match as_abstract x with Some (loc2, an2) -> (match Ag_ocaml.get_ocaml_module_and_t `Validate name an with None -> None | Some (types_module, main_module, ext_name) -> let args = List.map (fun s -> `Tvar (loc, s)) param in Some (`External (loc, name, args, `External (types_module, main_module, ext_name), (Ag_validate.get_validator an2, false)) ) ) | None -> Some (mapping_of_expr is_shallow x) in { def_loc = loc; def_name = name; def_param = param; def_value = o; def_arepr = `Def { Ag_ocaml.ocaml_predef = ocaml_predef; ocaml_ddoc = doc; }; def_brepr = (None, false); } let fill_def_tbl defs l = List.iter ( function `Type (loc, (name, param, an), x) -> Hashtbl.add defs name x ) l let init_def_tbl () = Hashtbl.create 100 let make_def_tbl l = let defs = init_def_tbl () in fill_def_tbl defs l; defs let make_def_tbl2 l = let defs = init_def_tbl () in List.iter (fun (is_rec, l) -> fill_def_tbl defs l) l; defs let defs_of_atd_module_gen is_shallow l = List.map (function `Type def -> def_of_atd is_shallow def) l let defs_of_atd_module l = let defs = make_def_tbl l in let is_shallow = make_is_shallow defs in defs_of_atd_module_gen is_shallow l let defs_of_atd_modules l = let defs = make_def_tbl2 l in let is_shallow = make_is_shallow defs in List.map (fun (is_rec, l) -> (is_rec, defs_of_atd_module_gen is_shallow l)) l atdgen-1.9.1/src/ag_ov_run.ml000066400000000000000000000011041273120334000160530ustar00rootroot00000000000000let validate_list f path l = let rec loop f path i = function | [] -> None | x :: l -> let subpath = `Index i :: path in match f subpath x with None -> loop f path (i+1) l | err -> err in loop f path 0 l let validate_array f path a = let rec loop f path a len i = if i >= len then None else match f (`Index i :: path) a.(i) with None -> loop f path a len (i+1) | err -> err in loop f path a (Array.length a) 0 let validate_option f path = function None -> None | Some x -> f path x atdgen-1.9.1/src/ag_ox_emit.ml000066400000000000000000000174031273120334000162200ustar00rootroot00000000000000(* Tools shared between OCaml code generators. (ox means OCaml-X) *) open Printf open Ag_error open Ag_mapping type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def type 'a grouped_defs = (bool * 'a def list) list type name = (loc * loc * string) (* location of the containing record or variant, location of the field definition, field/constructor name *) type names = { field_names : name list list; poly_variant_names : name list list; classic_variant_names : name list list; } let rec extract_names_from_expr ?(is_root = false) root_loc acc (x : 'a expr) = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ -> acc | `Sum (loc, va, o, _) -> let l, (fn, pvn, cvn) = Array.fold_left (extract_names_from_variant root_loc) ([], acc) va in (match o with `Sum x -> (match x with `Poly -> (fn, l :: pvn, cvn) | `Classic -> if is_root then (fn, pvn, l :: cvn) else error loc "Anonymous classic variant types are not allowed \ by OCaml." ) | _ -> assert false ) | `Record (loc, fa, _, _) -> if is_root then let l, (fn, pvn, cvn) = Array.fold_left (extract_names_from_field root_loc) ([], acc) fa in (l :: fn, pvn, cvn) else error loc "Anonymous record types are not allowed by OCaml." | `Tuple (loc, ca, _, _) -> Array.fold_left (extract_names_from_cell root_loc) acc ca | `List (loc, x, _, _) | `Option (loc, x, _, _) | `Nullable (loc, x, _, _) | `Wrap (loc, x, _, _) -> extract_names_from_expr root_loc acc x | `Name (loc, _, l, _, _) -> List.fold_left (extract_names_from_expr root_loc) acc l | `External (loc, _, l, _, _) -> List.fold_left (extract_names_from_expr root_loc) acc l | `Tvar _ -> acc and extract_names_from_variant root_loc (l, acc) x = let l = match x.var_arepr with `Variant v -> (root_loc, x.var_loc, v.Ag_ocaml.ocaml_cons) :: l | _ -> assert false in match x.var_arg with None -> (l, acc) | Some x -> (l, extract_names_from_expr root_loc acc x) and extract_names_from_field root_loc (l, acc) x = let l = match x.f_arepr with `Field f -> (root_loc, x.f_loc, f.Ag_ocaml.ocaml_fname) :: l | _ -> assert false in (l, extract_names_from_expr root_loc acc x.f_value) and extract_names_from_cell root_loc acc x = extract_names_from_expr root_loc acc x.cel_value let extract_ocaml_names_from_defs l = let fn, pvn, cvn = List.fold_left ( fun acc def -> match def.def_value with None -> acc | Some x -> let root_loc = loc_of_mapping x in extract_names_from_expr ~is_root:true root_loc acc x ) ([], [], []) l in { field_names = List.rev fn; poly_variant_names = List.rev pvn; classic_variant_names = List.rev cvn; } let flatten_defs (grouped_defs : 'a grouped_defs) : 'a def list = List.flatten (List.map snd grouped_defs) let check_duplicate_names container_kind field_kind l = let tbl = Hashtbl.create 200 in List.iter ( fun (root_loc, loc, s) -> try let orig_loc = Hashtbl.find tbl s in let msg1 = sprintf "\ %s contains a %s that is already defined elsewhere and cannot be reused." (String.capitalize container_kind) field_kind in let msg2 = sprintf "First definition of %s %s." field_kind s in let msg3 = sprintf "\ Impossible second definition of %s %s. Use a different name, possibly by placing after the field name or variant name in the ATD type definition. can also be used after a whole record." field_kind s in if loc <> orig_loc then error3 root_loc msg1 orig_loc msg2 loc msg3 else error2 root_loc msg1 orig_loc msg2 with Not_found -> Hashtbl.add tbl s loc ) l let check_names x = check_duplicate_names "record type" "field name" (List.flatten x.field_names); check_duplicate_names "variant type" "constructor name" (List.flatten x.classic_variant_names) let check grouped_defs = let x = extract_ocaml_names_from_defs (flatten_defs grouped_defs) in check_names x let get_full_type_name x = let s = x.def_name in match x.def_param with [] -> s | [x] -> sprintf "'%s %s" x s | l -> let l = List.map (fun s -> "'" ^ s) l in sprintf "(%s) %s" (String.concat ", " l) s let anon_param_type_name s n_param = match n_param with | 0 -> s | 1 -> "_ " ^ s | n -> let underscores = Array.make n "_" in let params = String.concat ", " (Array.to_list underscores) in "(" ^ params ^ ") " ^ s (* Get a type expression that uses the original user-given name (e.g. not _1) *) let get_type_constraint ~original_types def = try let (poly_name, n_params) = Hashtbl.find original_types def.def_name in anon_param_type_name poly_name n_params with Not_found -> get_full_type_name def (* Classic variants and records need type annotations in order to allow constructor/field name disambiguation *) let needs_type_annot (x : _ expr) = match x with | `Record (_, _, `Record `Record, _) | `Sum (_, _, `Sum `Classic, _) -> true | _ -> false let insert_annot type_annot = match type_annot with | None -> "" | Some t -> sprintf " : %s" t (* Add an optional type annotation on an OCaml expression or pattern *) let opt_annot type_annot expr = match type_annot with | None -> expr | Some t -> sprintf "(%s : %s)" expr t (* Add an optional type annotation after all function parameters in a let binding (last thing before the equal sign) *) let opt_annot_def type_annot fun_param = match type_annot with | None -> fun_param | Some t -> sprintf "%s : %s" fun_param t let write_file file s = let oc = open_out_bin file in output_string oc s; close_out oc let write_ocaml out mli ml = match out with `Stdout -> printf "\ struct %s end : sig %s end " ml mli; flush stdout | `Files prefix -> write_file (prefix ^ ".mli") mli; write_file (prefix ^ ".ml") ml let is_exportable def = let s = def.def_name in s <> "" && s.[0] <> '_' && def.def_value <> None let make_record_creator deref x = match x.def_value with Some (`Record (loc, a, `Record `Record, _)) -> let s = x.def_name in let full_name = get_full_type_name x in let l = Array.to_list (Array.map (Ag_ocaml.map_record_creator_field deref) a) in let intf_params = List.map (fun (x, _, _) -> x) l in let intf = sprintf "\ val create_%s :%s unit -> %s (** Create a record of type {!%s}. *) " s (String.concat "" intf_params) full_name s in let impl_params = List.map (fun (_, x, _) -> x) l in let impl_fields = List.map (fun (_, _, x) -> x) l in let impl = sprintf "\ let create_%s %s () : %s = {%s } " s (String.concat "" impl_params) full_name (String.concat "" impl_fields) in intf, impl | _ -> "", "" let rec is_function (l : Ag_indent.t list) = match l with [] -> false | x :: _ -> match x with `Line _ -> false | `Block l -> is_function l | `Inline l -> is_function l | `Annot ("fun", _) -> true | `Annot (_, x) -> is_function [x] atdgen-1.9.1/src/ag_ox_emit.mli000066400000000000000000000016731273120334000163730ustar00rootroot00000000000000type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def type 'a grouped_defs = (bool * 'a def list) list val get_full_type_name : (_, _) Ag_mapping.def -> string val is_exportable : (_, _) Ag_mapping.def -> bool val make_record_creator : ((Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping -> (Ag_ocaml.atd_ocaml_repr, 'b) Ag_mapping.mapping) -> (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def -> string * string val opt_annot : string option -> string -> string val opt_annot_def : string option -> string -> string val insert_annot : string option -> string val get_type_constraint : original_types:(string, string * int) Hashtbl.t -> ('a, 'b) Ag_mapping.def -> string val is_function : Ag_indent.t list -> bool val needs_type_annot : _ expr -> bool val check : _ grouped_defs -> unit val write_ocaml : [< `Files of string | `Stdout ] -> string -> string -> unit atdgen-1.9.1/src/ag_string_match.ml000066400000000000000000000172661273120334000172450ustar00rootroot00000000000000 open Printf type position = [ `Length | `Position of int | `End ] type value = [ `Int of int | `Char of char ] type 'a tree = [ `Node of (position * (value * 'a tree) list) | `Branch of ((position * value) list * 'a tree) | `Leaf of 'a ] let group_by f l = let tbl = Hashtbl.create 20 in List.iter ( fun x -> let k = f x in let r = try Hashtbl.find tbl k with Not_found -> let r = ref [] in Hashtbl.add tbl k r; r in r := x :: !r ) l; let l = Hashtbl.fold (fun k r l -> (k, List.rev !r) :: l) tbl [] in List.sort (fun (k1, _) (k2, _) -> compare k1 k2) l let rec finish s pos = match pos with `End -> [] | `Length -> (`Length, `Int (String.length s)) :: finish s (`Position 0) | `Position i -> if i < String.length s then (pos, `Char s.[i]) :: finish s (`Position (i+1)) else finish s `End let make_end_branch s pos x = match finish s pos with [] -> `Leaf x | l -> `Branch (l, `Leaf x) (* Create branches where possible. As a result, all the nodes become part of a branch. *) let rec make_branches (x : 'a tree) : 'a tree = match x with `Leaf _ -> x | `Branch (l, x) -> (match make_branches x with `Branch (l2, x2) -> `Branch ((l @ l2), x2) | x -> `Branch (l, x)) | `Node (pos, [ value, x ]) -> (match make_branches x with `Branch (l2, x2) -> `Branch (((pos, value) :: l2), x2) | x -> `Branch ([pos, value], x)) | `Node (pos, l) -> `Node (pos, List.map (fun (value, x) -> (value, make_branches x)) l) let make_initial_tree l : 'a tree = let rec aux i = function [] -> assert false | [ (s, x) ] -> let pos = if i < String.length s then `Position i else `End in make_end_branch s pos x | ((s, _) :: _) as l -> if i < String.length s then let groups = group_by (fun (s, _) -> `Char s.[i]) l in `Node (`Position i, List.map (fun (k, l) -> (k, aux (i+1) l)) groups) else (* reached end of string but multiple strings remain *) invalid_arg (sprintf "String_match.make_tree: duplicate key %S" s) in match l with [] -> `Node (`Length, []) | [ (s, x) ] -> make_end_branch s `Length x | l -> let groups = group_by (fun (s, _) -> `Int (String.length s)) l in `Node (`Length, List.map (fun (k, l) -> (k, aux 0 l)) groups) let make_tree l = make_branches (make_initial_tree l) let test () = let l = [ "abcdeg"; "abcdef"; "abdefh"; "bcd"; ""; ] in make_tree (List.map (fun s -> (s, s)) l) let get_value string_id pos_id pos = match pos with `Length -> "len" | `Position i -> if i = 0 then sprintf "String.unsafe_get %s %s" string_id pos_id else sprintf "String.unsafe_get %s (%s+%i)" string_id pos_id i | `End -> assert false let make_pattern value = match value with `Int i -> string_of_int i | `Char c -> sprintf "%C" c let cond test if_true if_false = [ `Line (sprintf "if %s then (" test); `Block if_true; `Line ")"; `Line "else ("; `Block if_false; `Line ")"; ] let make_branch_test string_id pos_id = function (`Length, `Int n) -> sprintf "len = %i" n | (`Position i, `Char c) -> if i = 0 then sprintf "String.unsafe_get %s %s = %C" string_id pos_id c else sprintf "String.unsafe_get %s (%s+%i) = %C" string_id pos_id i c | _ -> assert false let make_branch_tests string_id pos_id l = String.concat " && " (List.map (make_branch_test string_id pos_id) l) let rec map_to_ocaml string_id pos_id e = function `Leaf expr -> expr | `Branch (l, x) -> cond (make_branch_tests string_id pos_id l) (map_to_ocaml string_id pos_id e x) e | `Node (pos, l) -> [ `Line (sprintf "match %s with" (get_value string_id pos_id pos)); `Block [ `Inline (List.map (make_case string_id pos_id e) l); `Line "| _ -> ("; `Block [ `Block e; `Line ")"; ]; ] ] and make_case string_id pos_id e (value, tree) = `Inline [ `Line (sprintf "| %s -> (" (make_pattern value)); `Block [ `Block (map_to_ocaml string_id pos_id e tree); `Line ")"; ]; ] type exit_with = [ `Exn of string | `Expr ] let make_ocaml_expr_factored ?(string_id = "s") ?(pos_id = "pos") ?(len_id = "len") ?(exit_with = `Exn "Exit") ~error_expr cases : Ag_indent.t list = let exit_expr, catch = match exit_with with `Expr -> error_expr, (fun x -> x) | `Exn error_exn -> let exit_expr = [ `Line (sprintf "raise (%s)" error_exn) ] in let catch x = [ `Line "try"; `Block x; `Line (sprintf "with %s -> (" error_exn); `Block [ `Block error_expr; `Line ")"; ]; ] in exit_expr, catch in match cases with [] -> error_expr | l -> catch (map_to_ocaml string_id pos_id exit_expr (make_tree cases)) let test () = let l = [ "abc"; "abcd"; "abde"; "bcd"; ""; ] in let cases = List.map (fun s -> (s, [ `Line (sprintf "Some `Case_%s" s) ])) l in let expr = make_ocaml_expr_factored ~error_expr:[ `Line "None" ] cases in Atd_indent.to_stdout (List.map Ag_indent.strip expr) let make_ocaml_expr_naive ?(string_id = "s") ?(pos_id = "pos") ?(len_id = "len") ~error_expr cases = let map (s, expr) = `Inline [ `Line (sprintf "| %S ->" s); `Block expr; ] in [ `Line (sprintf "match %s with" string_id); `Block [ `Inline (List.map map cases); `Line "| _ ->"; `Block error_expr; ] ] let make_ocaml_expr ~optimized ?string_id ?pos_id ?len_id ?exit_with ~error_expr cases : Ag_indent.t list = if optimized then make_ocaml_expr_factored ?string_id ?pos_id ?len_id ?exit_with ~error_expr cases else make_ocaml_expr_naive ?string_id ?pos_id ?len_id ~error_expr cases let make_ocaml_int_mapping ?(string_id = "s") ?(pos_id = "pos") ?(len_id = "len") ?exit_with ~error_expr1 ?(error_expr2 = [ `Line "assert false" ]) ?(int_id = "i") cases : Ag_indent.t list * Ag_indent.t list = let a = Array.of_list cases in let int_cases = Array.mapi (fun i (s, x) -> (s, [ `Line (string_of_int i) ])) a in let int_mapping_body = make_ocaml_expr_factored ~string_id ~pos_id ~len_id ?exit_with ~error_expr: error_expr1 (Array.to_list int_cases) in let int_mapping_function = [ `Line (sprintf "fun %s %s %s ->" string_id pos_id len_id); `Block [ `Line ( sprintf "if %s < 0 || %s < 0 || %s + %s > String.length %s then" pos_id len_id pos_id len_id string_id ); `Block [ `Line "invalid_arg \"out-of-bounds substring position or length\";"; ]; `Inline int_mapping_body; ]; ] in let int_matching_cases = Array.mapi ( fun i (s, x) -> `Inline [ `Line (sprintf "| %i ->" i); `Block x; ] ) a in let int_matching = [ `Line (sprintf "match %s with" int_id); `Block [ `Inline (Array.to_list int_matching_cases); `Line "| _ -> ("; `Block [ `Block error_expr2; `Line ")"; ]; ]; ] in int_mapping_function, int_matching atdgen-1.9.1/src/ag_string_match.mli000066400000000000000000000044671273120334000174150ustar00rootroot00000000000000 (* Compilation of string pattern matching into something supposedly faster than what ocamlopt does. *) type position = [ `Length | `Position of int | `End ] type value = [ `Int of int | `Char of char ] type 'a tree = [ `Node of (position * (value * 'a tree) list) | `Branch of ((position * value) list * 'a tree) | `Leaf of 'a ] val make_tree : (string * 'a) list -> 'a tree type exit_with = [ `Exn of string | `Expr ] (** [`Exn s] raises an exception for each failure branch, and this exception is caught in one place, avoiding duplication of the [error_expr] expression. [`Expr] uses the [error_expr] in each failure branch, resulting in code duplication but avoiding raising and catching an exception. Suitable for fixed-length values for which code duplication is tolerable. *) val make_ocaml_expr_factored : ?string_id: string -> ?pos_id: string -> ?len_id: string -> ?exit_with: exit_with -> error_expr: Ag_indent.t list -> (string * Ag_indent.t list) list -> Ag_indent.t list val make_ocaml_expr_naive : ?string_id: string -> ?pos_id: string -> ?len_id: string -> error_expr: Ag_indent.t list -> (string * Ag_indent.t list) list -> Ag_indent.t list val make_ocaml_expr : optimized: bool -> ?string_id: string -> ?pos_id: string -> ?len_id: string -> ?exit_with: exit_with -> error_expr: Ag_indent.t list -> (string * Ag_indent.t list) list -> Ag_indent.t list val make_ocaml_int_mapping : ?string_id: string -> ?pos_id: string -> ?len_id: string -> ?exit_with: exit_with -> error_expr1: Ag_indent.t list -> ?error_expr2: Ag_indent.t list -> ?int_id: string -> (string * Ag_indent.t list) list -> (Ag_indent.t list * Ag_indent.t list) (* takes a list of cases, each being defined by a string to match against and by a corresponding expression of type 'a. returns: - function expression of type string -> int -> int -> int (maps a substring to an int corresponding to one of the strings to match against) - match-with expression of type 'a (matches s against the ints corresponding to the strings to match against) The whole point is to read records or variants without creating new strings or closures. *) atdgen-1.9.1/src/ag_util.ml000066400000000000000000000144241273120334000155310ustar00rootroot00000000000000 type 'a ocaml_array = 'a array let input_file fname read = let ic = open_in_bin fname in try let x = read ic in close_in ic; x with e -> close_in_noerr ic; raise e let output_file fname write = let oc = open_out_bin fname in try write oc; close_out oc with e -> close_out_noerr oc; raise e module Biniou = struct type 'a reader = Bi_inbuf.t -> 'a type 'a writer = Bi_outbuf.t -> 'a -> unit let from_channel ?len ?(shrlen = 0) read ic = let ib = Bi_inbuf.from_channel ?len ~shrlen ic in read ib let from_file ?len ?(shrlen = 0) read fname = input_file fname (fun ic -> from_channel ?len ~shrlen read ic) let to_channel ?len ?(shrlen = 0) write oc x = let ob = Bi_outbuf.create_channel_writer ?len ~shrlen oc in write ob x; Bi_outbuf.flush_channel_writer ob let to_file ?len ?(shrlen = 0) write fname x = output_file fname (fun oc -> to_channel ?len ~shrlen write oc x) end module Json = struct type 'a reader = Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a type 'a writer = Bi_outbuf.t -> 'a -> unit let finish ls lexbuf = Yojson.Safe.read_space ls lexbuf; if not (Yojson.Safe.read_eof lexbuf) then Yojson.json_error "Junk after end of JSON value" let from_lexbuf ?(stream = false) read ls lexbuf = Yojson.Safe.read_space ls lexbuf; let x = if Yojson.Safe.read_eof lexbuf then raise Yojson.End_of_input else read ls lexbuf in if not stream then finish ls lexbuf; x let from_string ?buf ?fname ?lnum read s = let lexbuf = Lexing.from_string s in let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in from_lexbuf read ls lexbuf let from_channel ?buf ?fname ?lnum read ic = let lexbuf = Lexing.from_channel ic in let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in from_lexbuf read ls lexbuf let from_file ?buf ?fname:src ?lnum read fname = let fname0 = match src with None -> fname | Some s -> s in input_file fname (fun ic -> from_channel ?buf ~fname:fname0 ?lnum read ic) let stream_from_lexbuf ?(fin = fun () -> ()) read ls lexbuf = let stream = Some true in let rec f i = try Some (from_lexbuf ?stream read ls lexbuf) with Yojson.End_of_input -> fin (); None | e -> (try fin () with _ -> ()); raise e in Stream.from f let stream_from_string ?buf ?fin ?fname ?lnum read ic = let lexbuf = Lexing.from_string ic in let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in stream_from_lexbuf ?fin read ls lexbuf let stream_from_channel ?buf ?fin ?fname ?lnum read ic = let lexbuf = Lexing.from_channel ic in let ls = Yojson.Safe.init_lexer ?buf ?fname ?lnum () in stream_from_lexbuf ?fin read ls lexbuf let stream_from_file ?buf ?(fin = fun () -> ()) ?fname:src ?lnum read fname = let fname0 = match src with None -> fname | Some s -> s in let ic = open_in_bin fname in let fin () = close_in_noerr ic; fin () in stream_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic let list_from_string ?buf ?fin ?fname ?lnum read ic = let stream = stream_from_string ?buf ?fin ?fname ?lnum read ic in let acc = ref [] in Stream.iter (fun x -> acc := x :: !acc) stream; List.rev !acc let list_from_channel ?buf ?fin ?fname ?lnum read ic = let stream = stream_from_channel ?buf ?fin ?fname ?lnum read ic in let acc = ref [] in Stream.iter (fun x -> acc := x :: !acc) stream; List.rev !acc let list_from_file ?buf ?fname:src ?lnum read fname = let fname0 = match src with None -> fname | Some s -> s in let ic = open_in_bin fname in let fin () = close_in_noerr ic in list_from_channel ?buf ~fin ~fname:fname0 ?lnum read ic let to_string ?(len = 1024) write x = let ob = Bi_outbuf.create len in write ob x; Bi_outbuf.contents ob let to_channel ?len write oc x = Biniou.to_channel ?len ~shrlen:0 write oc x let to_file ?len write fname x = Biniou.to_file ?len ~shrlen:0 write fname x let stream_to_string ?(len = 1024) ?(lf = "\n") write stream = let ob = Bi_outbuf.create len in Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream; Bi_outbuf.contents ob let stream_to_channel ?len ?(lf = "\n") write oc stream = let ob = Bi_outbuf.create_channel_writer ?len ~shrlen:0 oc in Stream.iter (fun x -> write ob x; Bi_outbuf.add_string ob lf) stream; Bi_outbuf.flush_channel_writer ob let stream_to_file ?len ?lf write fname stream = output_file fname (fun oc -> stream_to_channel ?len ?lf write oc stream) let list_to_string ?len ?lf write l = stream_to_string ?len ?lf write (Stream.of_list l) let list_to_channel ?len ?lf write oc l = stream_to_channel ?len ?lf write oc (Stream.of_list l) let list_to_file ?len ?lf write fname l = stream_to_file ?len ?lf write fname (Stream.of_list l) let preset_unknown_field_handler loc name = let msg = Printf.sprintf "Found unknown JSON field %s while expecting type defined at: %s" name loc in failwith msg let unknown_field_handler = ref preset_unknown_field_handler let preset_constr_mismatch_handler constr_field constr_constr value_field value_constr = let msg = Printf.sprintf "Field %s has constructor %s but field %s expects constructor %s" value_field value_constr constr_field constr_constr in Ag_oj_run.error msg let constr_mismatch_handler = ref preset_constr_mismatch_handler end module Validation = struct type path_elem = [ `Field of string | `Index of int ] type path = path_elem list let string_of_path l = String.concat "" ( List.rev_map ( function | `Field s -> "." ^ s | `Index n -> "[" ^ string_of_int n ^ "]" ) l ) type error = { error_path : path; error_msg : string option; } let error ?msg path = { error_path = path; error_msg = msg; } let string_of_error x = let path = string_of_path x.error_path in match x.error_msg with None -> "Validation error; path = " ^ path | Some msg -> Printf.sprintf "Validation error: %s; path = %s" msg path end atdgen-1.9.1/src/ag_util.mli000066400000000000000000000400201273120334000156710ustar00rootroot00000000000000(** Various convenience types and functions *) type 'a ocaml_array = 'a array (** An alias for OCaml's standard array type, used in generated code. *) module Biniou : sig type 'a reader = Bi_inbuf.t -> 'a (** Type of a [read_] function as produced by [atdgen -biniou]. *) type 'a writer = Bi_outbuf.t -> 'a -> unit (** Type of a [write_] function as produced by [atdgen -biniou]. *) val from_channel : ?len:int -> ?shrlen:int -> 'a reader -> in_channel -> 'a (** Read a biniou value from a channel. @param len input buffer length. @param shrlen obsolete and ignored. *) val from_file : ?len:int -> ?shrlen:int -> 'a reader -> string -> 'a (** Read a biniou value from a file. @param len input buffer length. @param shrlen obsolete and ignored. *) val to_channel : ?len:int -> ?shrlen:int -> 'a writer -> out_channel -> 'a -> unit (** Write a biniou value to a channel. @param len output buffer length. @param shrlen obsolete and ignored. *) val to_file : ?len:int -> ?shrlen:int -> 'a writer -> string -> 'a -> unit (** Write a biniou value to a file. @param len output buffer length. @param shrlen obsolete and ignored. *) end module Json : sig type 'a reader = Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a (** Type of a [read_] function as produced by [atdgen -json]. In versions of yojson greater than 1.0.1, type [Yojson.Safe.lexer_state] is equivalent to [Yojson.lexer_state], [Yojson.Basic.lexer_state] and [Yojson.Raw.lexer_state]. *) type 'a writer = Bi_outbuf.t -> 'a -> unit (** Type of a [write_] function as produced by [atdgen -json]. *) val from_lexbuf : ?stream:bool -> 'a reader -> Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a (** Read a JSON value from a lexbuf. @param stream if [true], the JSON parser will not try to consume whitespace until the end of file. Default is [false], which raises a [Yojson.Json_error] exception if the valid JSON value is followed by anything other than standard JSON whitespace. *) val from_string : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a (** Convert a JSON value from a string. @param buf buffer used to accumulate string data during the lexing phase. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val from_channel : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int -> 'a reader -> in_channel -> 'a (** Read a JSON value from a channel. @param buf buffer used to accumulate string data during the lexing phase. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val from_file : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a (** Read a JSON value from a channel. @param buf buffer used to accumulate string data during the lexing phase. @param fname input file name to be used in error messages. It is intended to represent the source file if it is different from the input file. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val stream_from_lexbuf : ?fin:(unit -> unit) -> 'a reader -> Yojson.Safe.lexer_state -> Lexing.lexbuf -> 'a Stream.t (** Read a stream of JSON values from a lexbuf. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This is typically used to close the input channel, e.g. [fun () -> close_in_noerr ic]. *) val stream_from_string : ?buf:Bi_outbuf.t -> ?fin:(unit -> unit) -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a Stream.t (** Read a stream of JSON values from a channel. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This is typically used to free the underlying resources, if any. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val stream_from_channel : ?buf:Bi_outbuf.t -> ?fin:(unit -> unit) -> ?fname:string -> ?lnum:int -> 'a reader -> in_channel -> 'a Stream.t (** Read a stream of JSON values from a channel. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This is typically used to close the input channel, e.g. [fun () -> close_in_noerr ic]. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val stream_from_file : ?buf:Bi_outbuf.t -> ?fin:(unit -> unit) -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a Stream.t (** Read a stream of JSON values from a file. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This can be used to remove the input file if it was temporary, e.g. [fun () -> Sys.remove fname]. @param fname input file name to be used in error messages. It is intended to represent the source file if it is different from the input file. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val list_from_string : ?buf:Bi_outbuf.t -> ?fin:(unit -> unit) -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a list (** Read a list of JSON values from a channel. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This is typically used to free the underlying resources, if any. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val list_from_channel : ?buf:Bi_outbuf.t -> ?fin:(unit -> unit) -> ?fname:string -> ?lnum:int -> 'a reader -> in_channel -> 'a list (** Read a list of JSON values from a channel. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fin finalization function executed once when the end of the stream is reached either because there is no more input or because of an exception. This is typically used to close the input channel, e.g. [fun () -> close_in_noerr ic]. @param fname input file name to be used in error messages. It does not have to be the name of a real file, it can be something like [""]. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val list_from_file : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int -> 'a reader -> string -> 'a list (** Read a list of JSON values from a file. Values do not have to be separated by newline characters. @param buf buffer used to accumulate string data during the lexing phase. @param fname input file name to be used in error messages. It is intended to represent the source file if it is different from the input file. @param lnum line number to assign to the first line of input. For example [lnum=10] means that an error on the first line of input will be reported as an error on line 10. Default: 1. *) val to_string : ?len:int -> 'a writer -> 'a -> string (** Write a JSON value to a string. @param len output buffer length. *) val to_channel : ?len:int -> 'a writer -> out_channel -> 'a -> unit (** Write a JSON value to a channel. @param len output buffer length. *) val to_file : ?len:int -> 'a writer -> string -> 'a -> unit (** Write a JSON value to a file. @param len output buffer length. *) val stream_to_string : ?len:int -> ?lf:string -> 'a writer -> 'a Stream.t -> string (** Write a stream of values to a string. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val stream_to_channel : ?len:int -> ?lf:string -> 'a writer -> out_channel -> 'a Stream.t -> unit (** Write a stream of values to a channel. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val stream_to_file : ?len:int -> ?lf:string -> 'a writer -> string -> 'a Stream.t -> unit (** Write a stream of values to a file. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val list_to_string : ?len:int -> ?lf:string -> 'a writer -> 'a list -> string (** Write a list of values to a string. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val list_to_channel : ?len:int -> ?lf:string -> 'a writer -> out_channel -> 'a list -> unit (** Write a list of values to a channel. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val list_to_file : ?len:int -> ?lf:string -> 'a writer -> string -> 'a list -> unit (** Write a list of values to a file. @param len output buffer length. @param lf additional element terminator. Default: ["\n"]. *) val preset_unknown_field_handler : string -> string -> unit (** [preset_unknown_field_handler src_loc field_name] raises a [Failure] exception with a message containing the location of the type definition in the source ATD file ([src_loc]) and the name of the field ([field_name]). *) val unknown_field_handler : (string -> string -> unit) ref (** Function called when an unknown JSON field is encountered if the code was generated by atdgen -json-strict-fields. Its preset behavior is to call [preset_unknown_field_handler] which raises a [Failure] exception. Usage: [!Ag_util.Json.unknown_field_handler src_loc field_name] where [src_loc] is the location of the type definition in the source ATD file and [field_name] is the unknown JSON field name. *) val preset_constr_mismatch_handler : string -> string -> string -> string -> unit (** [preset_constr_mismatch_handler constr_field constr_constr value_field value_constr] raises a [Ag_oj_run.Error] exception with a message containing the constructor field and value ([constr_field] and [constr_constr]) which don't match the value field's ([value_field]) constructor ([value_constr]). *) val constr_mismatch_handler : (string -> string -> string -> string -> unit) ref (** Function called when an explicit constructor field value does not match the constructor used if the code was generated by atdgen -json-strict-constrs. Its preset behavior is to call [preset_unknown_field_handler] which raises a [Ag_oj_run.Error] exception. Usage: [!Ag_util.Json.constr_mismatch_handler constr_field constr_constr value_field value_constr] where [constr_field] is the name of the constructor field, [constr_constr] is the constructor field value, [value_field] is the name of the value field, and [value_constr] is the constructor used. *) end module Validation : sig type path_elem = [ `Field of string | `Index of int ] type path = path_elem list (** Path within a value, used to report validation errors. *) val string_of_path : path -> string (** Reverse and concatenate a path into a string such as [".settings.ports[0]"] *) type error = { error_path : path; error_msg : string option; } val error : ?msg: string -> path -> error val string_of_error : error -> string end atdgen-1.9.1/src/ag_validate.ml000066400000000000000000000026721273120334000163470ustar00rootroot00000000000000(* Mapping from ATD to "validate" *) open Printf type validate_repr = (string option * bool) (* (opt_v, b) is obtained by analyzing all available type definitions. The first value opt_v is the optional local validator coming from an ATD annotation (see `Local). The second value b is true iff the data doesn't need scanning. There are four cases: opt_v = None && b = true => no validation is needed at all opt_v = None && b = false => validators must be called on some sub-fields of the data opt_v <> None && b = true => the given validator must be called but there's no need to look into the sub-fields opt_v <> None && b = false => the given validator must be called in addition to scanning sub-fields *) let make_full_validator s = sprintf "\ fun path x -> \ if ( %s ) x then None \ else Some (Ag_util.Validation.error path)" s let get_validator an = let full = Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "validator" an in match full with | Some _ -> full | None -> let shorthand = Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "valid" an in match shorthand with | None -> None | Some s -> Some (make_full_validator s) atdgen-1.9.1/src/ag_xb_emit.ml000066400000000000000000000103771273120334000162060ustar00rootroot00000000000000(* Tools shared between code generators for the biniou serialization format. (xb means X-Biniou) *) open Printf open Ag_error open Ag_mapping type 'a expr = ('a, Ag_biniou.biniou_repr) Ag_mapping.mapping type 'a def = ('a, Ag_biniou.biniou_repr) Ag_mapping.def type 'a grouped_defs = (bool * 'a def list) list type name = (loc * string) type names = { field_names : name list list; variant_names : name list list; } let rec extract_names_from_expr acc (x : 'a expr) = match x with `Unit _ | `Bool _ | `Int _ | `Float _ | `String _ -> acc | `Sum (loc, va, _, _) -> let l, (fn, vn) = Array.fold_left extract_names_from_variant ([], acc) va in (fn, List.rev l :: vn) | `Record (loc, fa, _, _) -> let l, (fn, vn) = Array.fold_left extract_names_from_field ([], acc) fa in (List.rev l :: fn, vn) | `Tuple (loc, ca, _, _) -> Array.fold_left extract_names_from_cell acc ca | `List (loc, x, _, _) | `Option (loc, x, _, _) | `Nullable (loc, x, _, _) | `Wrap (loc, x, _, _) -> extract_names_from_expr acc x | `Name (loc, _, l, _, _) -> List.fold_left extract_names_from_expr acc l | `External (loc, _, l, _, _) -> List.fold_left extract_names_from_expr acc l | `Tvar _ -> acc and extract_names_from_variant (l, acc) x = let l = (x.var_loc, x.var_cons) :: l in match x.var_arg with None -> (l, acc) | Some x -> (l, extract_names_from_expr acc x) and extract_names_from_field (l, acc) x = let l = (x.f_loc, x.f_name) :: l in (l, extract_names_from_expr acc x.f_value) and extract_names_from_cell acc x = extract_names_from_expr acc x.cel_value let extract_ocaml_names_from_defs l = let fn, vn = List.fold_left ( fun acc def -> match def.def_value with None -> acc | Some x -> extract_names_from_expr acc x ) ([], []) l in { field_names = List.rev fn; variant_names = List.rev vn; } let flatten_defs (grouped_defs : 'a grouped_defs) : 'a def list = List.flatten (List.map snd grouped_defs) let check_duplicate_hashes kind l = let tbl = Hashtbl.create 100 in List.iter ( fun (loc, s) -> let h = Bi_io.hash_name s in try let loc0, s0 = Hashtbl.find tbl h in error2 loc0 (sprintf "Definition of %s %s." kind s0) loc ( sprintf "\ Definition of %s %s. Both %s and %s have the same hash %i which makes them indistinguishable once in the Biniou format. Use different names." kind s s0 s h ) with Not_found -> Hashtbl.add tbl h (loc, s) ) l let check_hashes x = List.iter (check_duplicate_hashes "record field name") x.field_names; List.iter (check_duplicate_hashes "variant name") x.variant_names let check (l : 'a grouped_defs) = let x = extract_ocaml_names_from_defs (flatten_defs l) in check_hashes x (* let find_clashes () = let l = Mikmatch.Text.lines_of_file "/tmp/dictionary.txt" in (* let l1 = List.rev_map (fun s -> s ^ "1") l in let l2 = List.rev_map (fun s -> s ^ "2") l in let l3 = List.rev_map (fun s -> s ^ "3") l in let l4 = List.rev_map (fun s -> s ^ "4") l in let l = List.flatten [l; l1; l2; l3; l4] in *) let tbl = Hashtbl.create (2 * List.length l) in List.iter ( fun s -> let h = Bi_io.hash_name s in let r = try Hashtbl.find tbl h with Not_found -> let r = ref [] in Hashtbl.add tbl h r; r in r := s :: !r ) l; let clashes = Hashtbl.fold ( fun h r acc -> let l = !r in if List.length l >= 2 then List.rev l :: acc else acc ) tbl [] in let clashes = List.sort compare clashes in List.iter (fun l -> print_endline (String.concat " " l)) clashes *) (* Groups of words with identical biniou hashes obtained with find_clashes: bind1 classroom's3 bind2 classroom's4 commutes1 funerals4 expect1 tantalus4 idea chaw2 interval's1 middling2 interval's2 middling3 interval's3 middling4 militarily1 scheduled4 overviews neglects3 shea crew2 vacating maxine3 workshop1 examples3 workshop2 examples4 bevel reconveyed cogitate jutties premiums squigglier representationalists supervene *) atdgen-1.9.1/test/000077500000000000000000000000001273120334000137365ustar00rootroot00000000000000atdgen-1.9.1/test/.gitignore000066400000000000000000000006521273120334000157310ustar00rootroot00000000000000test-2.bin test-2.json test-json-files.json test-json-streams.json test-std.json test.bin test.json test.ml test.mli test2.ml test2.mli test2j.ml test2j.mli test3j.ml test3j.mli test4.ml test4.mli test4j.ml test4j.mli test5_b.ml test5_b.mli test5_j.ml test5_j.mli test5_t.ml test5_t.mli test_atdgen testdoc testj.ml testj.mli testjstd.ml testjstd.mli testv.ml testv.mli test3j_*.ml* test_type_conv_*.ml* test_atdgen_type_conv atdgen-1.9.1/test/Makefile000066400000000000000000000111061273120334000153750ustar00rootroot00000000000000.PHONY: default test really-test default: test ifeq "$(shell ocamlc -config | grep os_type)" "os_type: Win32" EXE=.exe else EXE= endif ATDGEN = ../src/atdgen$(EXE) test: $(MAKE) -C ../src OCAMLPATH=..:$$OCAMLPATH $(MAKE) really-test really-test: $(ATDGEN) test.atd $(ATDGEN) test2.atd $(ATDGEN) -json -extend Test \ -j-custom-fields \ 'fun loc s -> Printf.printf "Warning: skipping field %s (def: %s)\n" s loc' \ test.atd -o testj $(ATDGEN) -std-json -extend Test test.atd -o testjstd $(ATDGEN) -json -extend Test2 test2.atd -o test2j $(ATDGEN) -t test3j.atd $(ATDGEN) -j -j-std -j-strict-constrs test3j.atd $(ATDGEN) test4.atd $(ATDGEN) -json test4.atd -o test4j $(ATDGEN) -validate -extend Test test.atd -o testv $(ATDGEN) -o-name-overlap -t test5.atd $(ATDGEN) -o-name-overlap -j test5.atd $(ATDGEN) -o-name-overlap -b test5.atd $(ATDGEN) -t test_type_conv.atd -type-conv sexp -open "Sexplib.Std" ocamlfind ocamlc -c -package atdgen \ test5_t.mli test5_t.ml test5_j.mli test5_j.ml ocamlfind ocamlc -c -package atdgen \ test5_t.mli test5_t.ml test5_b.mli test5_b.ml ocamlfind ocamlopt -c -g test_lib.ml ocamlfind ocamlc -c -g test.mli -package atdgen ocamlfind ocamlopt -c -g test.ml -package atdgen ocamlfind ocamlc -c -g test2.mli -package atdgen ocamlfind ocamlopt -c -g test2.ml -package atdgen ocamlfind ocamlc -c -g test3j_t.mli test3j_j.mli -package atdgen ocamlfind ocamlopt -c -g test3j_t.ml test3j_j.ml -package atdgen ocamlfind ocamlc -c -g test4.mli -package atdgen ocamlfind ocamlopt -c -g test4.ml -package atdgen ocamlfind ocamlc -c -g testj.mli -package atdgen ocamlfind ocamlopt -c -g testj.ml -package atdgen ocamlfind ocamlc -c -g testjstd.mli -package atdgen ocamlfind ocamlopt -c -g testjstd.ml -package atdgen ocamlfind ocamlc -c -g test2j.mli -package atdgen ocamlfind ocamlopt -c -g test2j.ml -package atdgen ocamlfind ocamlc -c -g test4j.mli -package atdgen ocamlfind ocamlopt -c -g test4j.ml -package atdgen ocamlfind ocamlc -c -g testv.mli -package atdgen ocamlfind ocamlopt -c -g testv.ml -package atdgen ocamlfind ocamlopt -c -g test_atdgen_main.ml -package atdgen ocamlfind ocamlopt -o test_atdgen$(EXE) -g -linkpkg -package atdgen \ test_lib.cmx test.cmx test2.cmx testj.cmx testjstd.cmx \ test2j.cmx test3j_t.cmx test3j_j.cmx \ testv.cmx test_atdgen_main.cmx mkdir -p testdoc ocamlfind ocamldoc -html -d testdoc -package atdgen \ test.mli test2.mli testj.mli test2j.mli \ test3j_t.mli test4.mli test4j.mli testv.mli ./test_atdgen .PHONY: test-all test-all: really-test ocamlfind ocamlc -c -g -syntax camlp4o -package camlp4 \ -package sexplib -package sexplib.syntax \ test_type_conv_t.mli ocamlfind ocamlopt -c -g -syntax camlp4o -package camlp4 \ -package sexplib -package sexplib.syntax \ test_type_conv_t.ml ocamlfind ocamlopt -c -g test_atdgen_type_conv.ml -package atdgen -package sexplib ocamlfind ocamlopt -o test_atdgen_type_conv$(EXE) -g -linkpkg \ -syntax camlp4o -package camlp4 \ -package sexplib -package sexplib.syntax \ test_type_conv_t.cmx test_atdgen_type_conv.cmx ./test_atdgen_type_conv # Benchmarking and more testing .PHONY: bench bench: opt ocamlfind ocamlopt -c -g test_lib.ml -package atdgen # biniou $(ATDGEN) test.atd $(ATDGEN) -open Test test2.atd ocamlfind ocamlc -c -g test.mli -package atdgen ocamlfind ocamlopt -c -g test.ml -package atdgen ocamlfind ocamlc -c -g test2.mli -package atdgen ocamlfind ocamlopt -c -g test2.ml -package atdgen # json $(ATDGEN) -json -std-json -o testj -open Test -ntd test.atd $(ATDGEN) -json -std-json -o test2j -open Test,Test2,Testj -ntd \ test2.atd ocamlfind ocamlopt -c -g test_lib.ml ocamlfind ocamlc -c -g testj.mli -package atdgen ocamlfind ocamlopt -c -g testj.ml -package atdgen ocamlfind ocamlc -c -g test2j.mli -package atdgen ocamlfind ocamlopt -c -g test2j.ml -package atdgen # comparison ocamlfind ocamlopt -c -g -syntax camlp4o \ -package json-static,atdgen,unix \ benchmark.ml ocamlfind ocamlopt -o benchmark -g \ test_lib.cmx test.cmx test2.cmx testj.cmx test2j.cmx \ benchmark.cmx \ -package atdgen,unix,json-wheel -linkpkg .PHONY: clean clean: rm -f *.o *.a *.cm* *~ *.annot \ benchmark test_atdgen \ gmon.out ocamlprof.dump \ test.bin test-2.bin test.json test-2.json \ test-std.json test-json-files.json test-json-streams.json \ test.ml test.mli testj.ml testj.mli \ test2.ml test2.mli test2j.ml test2j.mli \ test3j.mli test3j.ml \ test4.mli test4.ml test4j.mli test4j.ml \ test5_b.mli test5_b.ml test5_j.mli test5_j.ml \ test5_t.mli test5_t.ml testjstd.ml testjstd.mli \ testv.ml testv.mli rm -rf testdoc atdgen-1.9.1/test/benchmark.ml000066400000000000000000000110761273120334000162270ustar00rootroot00000000000000 open Printf (*** Type definitions for json-static ***) open Test module C = struct type t = char let to_json x = Json_type.Int (Char.code x) let of_json = function Json_type.Int i when i >= 0 && i < 256 -> (Char.chr i) | _ -> failwith "corrupted json char" let t = `Int end module I32 = struct type t = int32 let to_json x = Json_type.String (Int32.to_string x) let of_json = function Json_type.String s -> (Int32.of_string s) | _ -> failwith "corrupted json int32" let t = `String end module I64 = struct type t = int64 let to_json x = Json_type.String (Int64.to_string x) let of_json = function Json_type.String s -> (Int64.of_string s) | _ -> failwith "corrupted json int64" let t = `String end let json_of_unit () = Json_type.Null let unit_of_json = function Json_type.Null -> () | _ -> failwith "error: expected null" type json test_variant = predefined [ `Case1 | `Case2 of int | `Case3 of string | `Case4 of test_variant list ] and mixed_record = predefined { ?field0 : int option; ?field1 : float option; field2 : string option; field3 : I64.t; field4 : float array; ?field5 : bool option; ?field6 : string option; field7 : test_variant; field8 : string array; field9 : ( int * int * C.t * int * I32.t * I64.t ); field10 : bool; ?field11 : bool = false; field12 : unit list; field13 : string option list } and mixed = (mixed_record array * mixed_record array) list (*** Creation of sample data for testing ***) let make_mixed_record_array n = Array.init n ( fun i -> { field0 = Some i; field1 = Some 0.555; field2 = Some (String.copy "abcdefghijklmnopqrstuvwxyz"); field3 = 12345678L; field4 = [| 1.23; 3.45; 4.56 |]; field5 = None; field6 = None; field7 = `Case4 [ `Case1; `Case2 999; `Case3 "abcdefghij"; `Case4 [] ]; field8 = [| "a"; "bc"; "def"; "ghij"; "klmno"; "pqrstu"; "vwxyz01"; "23456789" |]; field9 = ( 1_000_000, 0xff, '\xff', 0xffff, 0xffffffffl, 0xffffffffffffffffL ); field10 = true; field11 = false; field12 = [ (); () ]; field13 = [ Some "abcdefgh"; None; Some "qwerty" ] } ) let make_mixed ~top_len ~tab_len ~ar_len = Array.to_list ( Array.init top_len ( fun _ -> (make_mixed_record_array tab_len, make_mixed_record_array ar_len) ) ) (*** Benchmarking ***) let time s f x = printf "%s: %!" s; let t1 = Unix.gettimeofday () in let y = f x in let t2 = Unix.gettimeofday () in printf "%.3f s\n%!" (t2 -. t1); y let print_length label s = printf "%s len = %i\n" label (String.length s) let marshal_mixed x = let s = Marshal.to_string x [Marshal.No_sharing] in print_length "marshal" s; s let unmarshal_mixed s = (Marshal.from_string s 0 : mixed) let jsonstatic_of_mixed x = let s = Json_io.string_of_json ~compact:true (json_of_mixed x) in print_length "json-static" s; s let mixed_of_jsonstatic s = mixed_of_json (Json_io.json_of_string s) let biniou_of_mixed x = let s = Test.string_of_mixed ~len:10_000_000 x in print_length "atdgen-biniou" s; s let mixed_of_biniou s = Test.mixed_of_string s let atdgenjson_of_mixed x = let s = Testj.string_of_mixed ~len:10_000_000 x in print_length "atdgen-json" s; s let mixed_of_atdgenjson s = Testj.mixed_of_string s let compact () = printf "[compaction]\n%!"; Gc.compact () let single_perf_test () = let x = make_mixed ~top_len:100 ~tab_len:500 ~ar_len:500 in if true then ( compact (); let marshal_s = time "marshal write" marshal_mixed x in compact (); ignore (time "marshal read" unmarshal_mixed marshal_s); ); if true then ( compact (); let biniou_s = time "atdgen-biniou write" biniou_of_mixed x in compact (); ignore (time "atdgen-biniou read" mixed_of_biniou biniou_s); ); if true then ( compact (); let json_s = time "atdgen-json write" atdgenjson_of_mixed x in compact (); ignore (time "atdgen-json read" mixed_of_atdgenjson json_s); ); if true then ( compact (); let json_s = time "json-static write" jsonstatic_of_mixed x in compact (); ignore (time "json-static read" mixed_of_jsonstatic json_s); ) let perf_test () = Gc.set { (Gc.get()) with Gc.verbose = 0x020 }; let n = 2 in for i = 1 to n do printf "[run %i/%i]\n%!" i n; if i = 2 then Gc.set { (Gc.get()) with Gc.space_overhead = 500 }; single_perf_test () done let () = perf_test () atdgen-1.9.1/test/test.atd000066400000000000000000000117421273120334000154140ustar00rootroot00000000000000 type def = abstract type r = { a : int ; b : bool; c : p; } type p = [ A | B of r | C ] type star_rating = int type p'' = int p' type 'a p' = [ A | Bb of 'a p' | Ccccc of 'a ] type hello = [ Hello of string | World ] type tup = (int * test) type test_variant = [ Case1 | Case2 of int | Case3 of string | Case4 of test_variant list ] type date = (int * int nullable * int nullable) type floats = { f32 : float ; f64 : float; } type mixed_record = { ?field0 : int option; ?field1 : float option; field2 : string option; field3 : int ; field4 : float list ; ?field5 : bool option; ?field6 : string option; field7 : test_variant; field8 : string list ; field9 : ( int * int * int * int * int * int ); field10 : bool; ~field11 : bool; field12 : unit list; field13 : string option list; field14 : date; } type mixed = (mixed_record list * mixed_record list ) list type test = { ?x0 : int option; ?x1 : float option; x2 : mixed; x3 : mixed_record list; x4 : int ; } type base = { b0 : int; b1 : bool; } type extended = { b0 : int; b1 : bool ; b2 : string; ?b3 : string option; b4 : string option; ~b5 : float; } = 0 then None else Some (Ag_util.Validation.error path)"> type val1 = { val1_x : int } type val2 = { val2_x : val1; ?val2_y : val1 option; } type base_tuple = (int * float) type extended_tuple = (int * float * : bool * : int option * string * : string list) type option_validation = int option type ('x, 'y) poly = { fst : 'x list; snd : ('x, 'y) poly option; } (* type field_hash_clash = { workshop1 : bool; examples3 : bool; } type variant_hash_clash = [ X_workshop1 | X_examples3 ] *) type int_assoc_list = (string * int) list type int_assoc_array = (string * int) list type 'a abs1 = 'a list type 'a abs2 = 'a list type 'a abs3 = 'a list type intopt = int option type int8 = int type char = int type int32 = int type int64 = int type 'a array = 'a list type id = string wrap failwith \"empty\" | _ -> None"> type json_map = (id * int) list type natural = int wrap type even_natural = natural wrap type some_record = { some_field : int } type no_real_wrap = some_record wrap type unixtime_list = float list type precision = { sqrt2_5 : float ; small_2 : float ; large_2 : float ; } type 'a generic = { x294623: int; } type specialized = string generic type validate_me = string list atdgen-1.9.1/test/test2.atd000066400000000000000000000004051273120334000154700ustar00rootroot00000000000000type ('aa, 'bb) poly = abstract type poly_int2 = (int, int) poly type poly_int_string = (int, string) poly type test2 = { test0 : poly_int2; test1 : (int, string option) poly } atdgen-1.9.1/test/test3j.atd000066400000000000000000000047151273120334000156530ustar00rootroot00000000000000(* JSON support only *) type json = abstract type dyn = abstract type t = { foo: int; bar: json; baz: dyn } type unixtime_list = int list (*** JSON records using one field to indicate the type of other fields ***) (* Support for the following JSON records: { "type": "integer", data: 123 } -> { data = `Integer 123 } { "type": "string", data: "abc" } -> { data = `String "abc" } *) type simple = { data : integer_or_string; (* JSON object has one extra field "type" that must contain the constructor for the OCaml variant. integer_or_string is a variant type, broken into 2 fields in the JSON representation. *) } type integer_or_string = [ | Integer of int | String of string ] (* More complex cases *) type tag = [ | A | B | C ] type constr = [ | A | B of int | C of string ] type inter_constr = [ | A of constr | B of constr | C of constr ] type constr_record = { int_field : int; tag_field : string; constr_field : constr; string_field : string; } type implicit_constr_record = { implicit_constr_field1 : constr; implicit_constr_field2 : constr; } type tag_record = { tag : tag; constr : constr; } type multi_constr_record = { multi_tag : tag; first_constr : constr; second_constr : inter_constr; } type default_tag_record = { ~default_tag : tag; default_tag_constr : constr; } type default_constr_record = { default_constr_tag : tag; ~default_constr : constr; } type default_record = { ~default2_tag : tag; ~default2_tag_constr : constr; } type default_implicit = { ~def_imp_constr : constr; } type chained_constr_record = { first_tag : tag; second_tag : inter_constr; chained_constr : constr; } atdgen-1.9.1/test/test4.atd000066400000000000000000000003201273120334000154660ustar00rootroot00000000000000 type 'x abs1 = abstract type 'x abs2 = abstract type 'x abs3 = abstract atdgen-1.9.1/test/test5.atd000066400000000000000000000010211273120334000154660ustar00rootroot00000000000000(* Basic testing of -allow-name-overlap *) type ab1 = { a : string; b : int; } type ab2 = { a : string; b : int; } type bca = { b : ab2 list; c : int list; a : float; } type cd1 = [ | C of int | D of string ] type cd2 = [ | C of float | D of bool ] type cde = [ | C of int | D of cd1 | E of cd2 ] type all = { a : ab1; b : ab2; c : bca list; d : cde list; } type contains_variant = { foo : string; bar : [ One | Two | Three of int ] } atdgen-1.9.1/test/test_atdgen_main.ml000066400000000000000000000607761273120334000176150ustar00rootroot00000000000000open Printf let current_section = ref "" let section = let first_section = ref true in fun name -> current_section := name; if !first_section then first_section := false; printf "----- %s -----\n%!" name let errors = ref [] exception Failed let fail () = errors := !current_section :: !errors; raise Failed let check b = if not b then fail () let check_valid = function | None -> () | Some error -> printf "%s\n%!" (Ag_util.Validation.string_of_error error); fail () let check_invalid = function | None -> fail () | Some error -> printf "%s\n%!" (Ag_util.Validation.string_of_error error) let expect_error f x = try ignore (f x); printf "Did not get expected error\n%!"; fail () with Ag_ob_run.Error s | Ag_oj_run.Error s -> printf "Got expected error:\n%s\n%!" s let test_missing_record = { Test.b0 = 123; b1 = true } let test_extended_record = { Test.b0x = 55; b1x = false; b2x = "abc"; b3x = Some "def"; b4x = Some "ghi"; b5x = 1.1; } let test_missing_tuple = (123, 4.56) type internals1 = { int : int } type internals2 = { float : float } (* Obj.magic 0.0, opaque_identity, and record fields Instead of using options (which may allocate), atdgen uses a default value for references that denote record fields that may not yet have been deserialized. For example, consider the following example in the test.ml generated code: type extended = { b0x: int; b1x: bool; b2x: string; b3x: string option; b4x: string option; b5x: float } let get_extended_reader = ( fun tag -> if tag <> 21 then Ag_ob_run.read_error () else fun ib -> let field_b0x = ref (Obj.magic (Sys.opaque_identity 0.0)) in let field_b1x = ref (Obj.magic (Sys.opaque_identity 0.0)) in let field_b2x = ref (Obj.magic (Sys.opaque_identity 0.0)) in let field_b3x = ref (None) in let field_b4x = ref (Obj.magic (Sys.opaque_identity 0.0)) in let field_b5x = ref (0.5) in let bits0 = ref 0 in let len = Bi_vint.read_uvint ib in for i = 1 to len do match Bi_io.read_field_hashtag ib with | 21902 -> field_b0x := ( ( Ag_ob_run.read_int ) ib ); bits0 := !bits0 lor 0x1; | 21903 -> field_b1x := ( ( Ag_ob_run.read_bool ) ib ); bits0 := !bits0 lor 0x2; (* ... CODE ELIDED HERE ... *) | 21907 -> field_b5x := ( ( Ag_ob_run.read_float64 ) ib ); | _ -> Bi_io.skip ib done; if !bits0 <> 0xf then Ag_ob_run.missing_fields [| !bits0 |] [| "b0"; "b1"; "b2"; "b4" |]; ( { b0x = !field_b0x; b1x = !field_b1x; b2x = !field_b2x; b3x = !field_b3x; b4x = !field_b4x; b5x = !field_b5x; } : extended) # Why Obj.magic? At code generation time we do not have a default value for the type of this field (we don't know what the type is), so we create one out of thin air with Obj.magic # Why 0.0? Atdgen does not run the type-checker, so it does not a-priori know if the field type is float (it may be a type alias of "float" or even depend on a functor parameter). If the type *is* float and the type-checker notices it statically, then it may allocate an unboxed float reference, and in particular unbox the default value passed at reference create time. If this default value was *not* a float, then the code could segfault. So in this case we must use a float value. If the type is *not* float, then passing a float value is still correct: the compiler will not try to unbox it, so a (word-sized) pointer will be stored in the reference. # Why Sys.opaque_identity? Starting from 4.03, the compiler is more clever at assuming things from values. When it sees the constant 0.0, it will infer in particular that the reference contains a float (so it may decide to unbox it!), etc. Notice that the compiler makes just the same assumptions about (Obj.magic 0.0) than about 0.0, the magic changes the type but not the value. Also in 4.03, the Sys.opaque_identity function was added in the Sys module; it is a compiler primitive of type ('a -> 'a) that prevents the compiler from assuming anything about its return value. In practice, using Sys.opaque_identity here avoids the segfault that happened without it on 4.03. Note that this may not be enough; in particular, (Sys.opaque_identity 0.0) is still recognizeably a value of "float" type to the compiler (only the value is unknown), so it would be legal for the compiler to still decide to unbox in the future! The long-term solution would be to stop using these unsafe Obj.magic and use an option type to store the reference fields in this case. This would be a more invasive change to the implementation. *) let test_ocaml_internals () = section "ocaml internals"; let opaque_identity = (* neat trick to fallback to just the identity if we are using a <4.03 version and Sys.opaque_identity is not available; found in https://github.com/LaurentMazare/tensorflow-ocaml/commit/111b4727cec992bab8bc67c22ccc8c31942ffbb2 *) let opaque_identity x = x in ignore opaque_identity; let open Sys in opaque_identity in let int = ref (Obj.magic (opaque_identity 0.0)) in Gc.compact (); int := 123; Gc.compact (); check ({ int = !int }.int = 123); let float = ref (Obj.magic 0) in Gc.compact (); float := 4.5; Gc.compact (); check ({ float = !float }.float = 4.5) let test_biniou_missing_field () = section "biniou missing record fields"; expect_error Test.extended_of_string (Test.string_of_base test_missing_record) let test_biniou_missing_cell () = section "biniou missing tuple fields"; expect_error Test.extended_tuple_of_string (Test.string_of_base_tuple test_missing_tuple) let test_json_missing_field () = section "json missing record fields"; expect_error Testj.extended_of_string (Testj.string_of_base test_missing_record) let test_json_missing_cell () = section "json missing tuple fields"; expect_error Testj.extended_tuple_of_string (Testj.string_of_base_tuple test_missing_tuple) let test_json_extra_field_warning () = section "json extra field warning"; ignore (Testj.base_of_string (Testj.string_of_extended test_extended_record)) let test_json_assoc_list () = section "json association list"; let f l = let s = Testj.string_of_int_assoc_list l in print_endline s; check (Testj.int_assoc_list_of_string s = l) in f []; f [ ("a", 0) ]; f [ ("a", 0); ("b", 1) ] let test_json_assoc_array () = section "json association array"; let f a = let s = Testj.string_of_int_assoc_array a in print_endline s; check (Testj.int_assoc_array_of_string s = a) in f [| |]; f [| ("a", 0) |]; f [| ("a", 0); ("b", 1) |] let test_json_int_ocaml_float_gen of_json to_json kind () = section ("json ints derived from ocaml floats: " ^ kind); let l1 = [0.; 0.1; -0.1; 0.6; -0.6] in check (of_json (to_json l1) = [0.; 0.; 0.; 1.; -1.]); let l2 = [ 12345678901234567890.; -12345678901234567890. ] in let l2' = of_json (to_json l2) in List.iter2 (fun x x' -> assert (abs_float (1. -. x /. x') < 1e-15)) l2 l2'; expect_error to_json [infinity]; expect_error to_json [neg_infinity]; expect_error to_json [nan] let test_json_int_ocaml_float () = test_json_int_ocaml_float_gen Test3j_j.unixtime_list_of_string Test3j_j.string_of_unixtime_list "int " (); test_json_int_ocaml_float_gen Testj.unixtime_list_of_string Testj.string_of_unixtime_list "float " () let make_mixed_record_array n = Array.init n ( fun i -> { Test.field0 = Some i; field1 = Some 0.555; field2 = Some (String.copy "abcdefghijklmnopqrstuvwxyz"); field3 = 12345678L; field4 = [| 1.23; 3.45; 4.56 |]; field5 = None; field6 = None; field7 = `Case4 [ `Case1; `Case2 999; `Case3 "abcdefghij"; `Case4 [] ]; field8 = [| "a"; "bc"; "def"; "ghij"; "klmno"; "pqrstu"; "vwxyz01"; "23456789" |]; field9 = ( 1_000_000, 0xff, '\xff', 0xffff, 0xffffffffl, 0xffffffffffffffffL ); field10 = true; field11 = false; field12 = [ (); () ]; field13 = [ Some "abc"; None ]; field14 = (2012, Some 3, None); } ) let make_mixed ~top_len ~tab_len ~ar_len = Array.to_list ( Array.init top_len ( fun _ -> (make_mixed_record_array tab_len, make_mixed_record_array ar_len) ) ) let test_correctness_data = { Test.x0 = Some 123; x1 = Some 1.23; x2 = make_mixed ~top_len:2 ~tab_len:2 ~ar_len:2; x3 = [ { Test.field0 = Some 1234; field1 = Some 1e6; field2 = Some "Hello"; field3 = 12345678L; field4 = [| 1.23; 3.45; 5.67 |]; field5 = None; field6 = None; field7 = `Case4 [ `Case1; `Case2 999; `Case3 "abcdefghij"; `Case4 [] ]; field8 = [| "abcdef"; "0123456789" |]; field9 = ( 1_000_000, 0xff, '\xff', 0xffff, 0xffffffffl, 0xffffffffffffffffL ); field10 = true; field11 = false; field12 = [ (); () ]; field13 = [ Some "abc"; None ]; field14 = (2012, Some 3, None); } ]; x4 = 0x0807060504030201L; } let save file s = let oc = open_out_bin file in output_string oc s; close_out oc let test_biniou_correctness () = section "biniou correctness"; let x = test_correctness_data in let s = Test.string_of_test x in save "test.bin" s; let x' = Test.test_of_string s in let s' = Test.string_of_test x' in let x'' = Test.test_of_string s' in save "test-2.bin" s'; if x <> x' then ( print_endline (Bi_io.view s); print_endline "Data don't match"; if s = s' then print_endline "Strings match" else print_endline "Strings don't match either"; if x' = x'' then print_endline "2nd and 3rd generation data match" else print_endline "2nd and 3rd generation data differ"; fail () ) let test_json_correctness () = section "json correctness"; let x = test_correctness_data in let s = Testj.string_of_test x in save "test.json" s; let x' = Testj.test_of_string s in let s' = Testj.string_of_test x' in let x'' = Testj.test_of_string s' in save "test-2.json" s'; let std_x' = Testjstd.test_of_string s in let std_s' = Testjstd.string_of_test std_x' in let std_x'' = Testjstd.test_of_string std_s' in save "test-std.json" std_s'; if x <> x' then ( print_endline (Yojson.Safe.prettify s); print_endline "Data don't match"; if s = s' then print_endline "Strings match" else print_endline "Strings don't match either"; if x' = x'' then print_endline "2nd and 3rd generation data match" else print_endline "2nd and 3rd generation data differ"; fail () ); check (std_x' = std_x''); assert (x = std_x') let test_json_space () = section "json space"; let s = Testj.string_of_test test_correctness_data in let pp = Yojson.Safe.prettify s in ignore (Testj.test_of_string pp) let test_validators0 () = section "validators0"; check_valid (Testv.validate_test [] test_correctness_data) let test_validators1 () = section "validators1"; let valid = (0, 1.) in let invalid = (1, 0.) in check_valid (Testv.validate_base_tuple [] valid); check_invalid (Testv.validate_base_tuple [] invalid); let x1 = { Test.b0x = 1; b1x = true; b2x = "abc"; b3x = Some "def"; b4x = Some "ghi"; b5x = 1.1; } in check_invalid (Testv.validate_extended [] x1); let x2 = { x1 with Test.b1x = false } in check_valid (Testv.validate_extended [] x2); let x3 = { x2 with Test.b0x = -1 } in check_invalid (Testv.validate_extended [] x3) let test_validators2 () = section "validators2"; let v1 = `A in check_invalid (Testv.validate_p [] v1); let v2 = `B { Test.a = 0; b = true; c = `C } in check_valid (Testv.validate_p [] v2) let test_validators3 () = section "validators3"; let o = Some 0 in check_invalid (Testv.validate_option_validation [] o) let test_validators4 () = section "validators4"; let x = { Test.val2_x = { Test.val1_x = 0 }; val2_y = Some { Test.val1_x = 1 } } in check_invalid (Testv.validate_val2 [] x) let test_json_files () = section "json files"; let x = Some 123 in let s = Ag_util.Json.to_string Testj.write_intopt x in print_endline s; let x' = Ag_util.Json.from_string Testj.read_intopt s in check (x = x'); Ag_util.Json.to_file Testj.write_intopt "test-json-files.json" x; let x'' = Ag_util.Json.from_file Testj.read_intopt "test-json-files.json" in check (x = x'') let test_json_streams () = section "json streams"; let l = [ Some 1; None; Some 2; Some 3 ] in let s = Ag_util.Json.list_to_string Testj.write_intopt l in print_endline s; let l' = Ag_util.Json.list_from_string Testj.read_intopt s in check (l = l'); Ag_util.Json.list_to_file Testj.write_intopt "test-json-streams.json" l; let l'' = Ag_util.Json.list_from_file Testj.read_intopt "test-json-streams.json" in check (l = l'') let test_raw_json () = section "raw json"; let x = { Test3j_t.foo = 12345; bar = `List [ `Int 12; `String "abc" ]; baz = `Bool false } in let s = Test3j_j.string_of_t x in let x' = Test3j_j.t_of_string s in check (x = x') let test_json_constr_mismatch () = section "json constructors mismatch"; let x = { Test3j_t.int_field = 1; string_field = "it's mismatch"; tag_field = "a"; constr_field = `B 52; } in expect_error Test3j_j.string_of_constr_record x let test_json_constr_nullary () = section "json constructors nullary"; let x = { Test3j_t.int_field = 0; string_field = "it's a"; tag_field = "a"; constr_field = `A; } in let s = Test3j_j.string_of_constr_record x in let x' = Test3j_j.constr_record_of_string s in check (x = x') let test_json_constr_unary () = section "json constructors unary"; let x = { Test3j_t.int_field = 2; string_field = "it's c"; tag_field = "c"; constr_field = `C "see the sea"; } in let s = Test3j_j.string_of_constr_record x in let x' = Test3j_j.constr_record_of_string s in check (x = x') let test_json_constr_implicit () = section "json constructors implicit"; let x = { Test3j_t.implicit_constr_field1 = `A; Test3j_t.implicit_constr_field2 = `A; } in let s = Test3j_j.string_of_implicit_constr_record x in let x'= Test3j_j.implicit_constr_record_of_string s in check (x = x'); let j = `Assoc ["implicit_tag_field", `String "a"] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.implicit_constr_field1 = `B 12; Test3j_t.implicit_constr_field2 = `B 13; } in let s = Test3j_j.string_of_implicit_constr_record x in let x'= Test3j_j.implicit_constr_record_of_string s in check (x = x'); let j = `Assoc [ "implicit_constr_field1", `Int 12; "implicit_constr_field2", `Int 13; "implicit_tag_field", `String "b"; ] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.implicit_constr_field1 = `B 12; Test3j_t.implicit_constr_field2 = `C "muahaha"; } in expect_error Test3j_j.string_of_implicit_constr_record x let test_json_constr_tag () = section "json constructors tag roundtrip"; let x = { Test3j_t.tag = `B; constr = `B 6 } in let s = Test3j_j.string_of_tag_record x in let x'= Test3j_j.tag_record_of_string s in check (x = x'); section "json constructors tag repr"; let j = `Assoc [ "tag", `String "b"; "constr", `Int 6 ] in let s = Yojson.Safe.to_string j in let s'= Test3j_j.string_of_tag_record x in check (s = s'); (* TODO: should this be an error? *) let j = `Assoc [ "constr", `String "what"; "tag", `String "a"; ] in let s = Yojson.Safe.to_string j in let x = Test3j_j.tag_record_of_string s in let x'= { Test3j_t.tag = `A; constr = `A } in check (x = x') let test_json_constr_multi () = section "json constructors multi"; let x = { Test3j_t.multi_tag = `B; Test3j_t.first_constr = `B 52; Test3j_t.second_constr = `B `A; } in let s = Test3j_j.string_of_multi_constr_record x in let x'= Test3j_j.multi_constr_record_of_string s in check (x = x'); let j = `Assoc [ "multi_tag", `String "b"; "first_constr", `Int 52; "second_constr", `String "a"; ] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.multi_tag = `C; Test3j_t.first_constr = `C "hel10"; Test3j_t.second_constr = `B (`C "goodbyte"); } in expect_error Test3j_j.string_of_multi_constr_record x let test_json_constr_default_tag () = section "json constructors default tag"; let x = { Test3j_t.default_tag = `B; Test3j_t.default_tag_constr = `B 12; } in let s = Test3j_j.string_of_default_tag_record x in let x'= Test3j_j.default_tag_record_of_string s in check (x = x'); let j = `Assoc ["default_tag_constr", `Int 12] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.default_tag = `A; Test3j_t.default_tag_constr = `A; } in let s = Test3j_j.string_of_default_tag_record x in let x'= Test3j_j.default_tag_record_of_string s in check (x = x'); let j = `Assoc ["default_tag", `String "a"] in let s' = Yojson.Safe.to_string j in check (s = s'); let j = `Assoc [] in let s = Yojson.Safe.to_string j in expect_error Test3j_j.default_tag_record_of_string s let test_json_constr_default_constr () = section "json constructors default constr"; let x = { Test3j_t.default_constr_tag = `B; Test3j_t.default_constr = `B 12; } in let s = Test3j_j.string_of_default_constr_record x in let x'= Test3j_j.default_constr_record_of_string s in check (x = x'); let j = `Assoc ["default_constr_tag", `String "b"] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.default_constr_tag = `B; Test3j_t.default_constr = `B 13; } in let s = Test3j_j.string_of_default_constr_record x in let x'= Test3j_j.default_constr_record_of_string s in check (x = x'); let j = `Assoc [ "default_constr_tag", `String "b"; "default_constr", `Int 13; ] in let s' = Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.default_constr_tag = `A; Test3j_t.default_constr = `A; } in let s = Test3j_j.string_of_default_constr_record x in let x'= Test3j_j.default_constr_record_of_string s in check (x = x'); let j = `Assoc ["default_constr_tag", `String "a"] in let s' = Yojson.Safe.to_string j in check (s = s'); let j = `Assoc ["default_constr_tag", `String "c"] in let s = Yojson.Safe.to_string j in expect_error Test3j_j.default_constr_record_of_string s let test_json_constr_default () = section "json constructors default both"; let x = { Test3j_t.default2_tag = `B; Test3j_t.default2_tag_constr = `B 12; } in let s = Test3j_j.string_of_default_record x in let x'= Test3j_j.default_record_of_string s in check (x = x'); let j = `Assoc [] in let s'= Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.default2_tag = `A; Test3j_t.default2_tag_constr = `A; } in let s = Test3j_j.string_of_default_record x in let x'= Test3j_j.default_record_of_string s in check (x = x'); let j = `Assoc ["default2_tag", `String "a"] in let s'= Yojson.Safe.to_string j in check (s = s'); let x = { Test3j_t.default2_tag = `B; Test3j_t.default2_tag_constr = `B 0; } in let s = Test3j_j.string_of_default_record x in let x'= Test3j_j.default_record_of_string s in check (x = x'); let j = `Assoc ["default2_tag_constr", `Int 0] in let s'= Yojson.Safe.to_string j in check (s = s'); let j = `Assoc ["default2_tag", `String "c"] in let s = Yojson.Safe.to_string j in expect_error Test3j_j.default_record_of_string s let test_json_constr_default_implicit () = section "json constructors default implicit"; let x = { Test3j_t.def_imp_constr = `B 12; } in let s = Test3j_j.string_of_default_implicit x in let x'= Test3j_j.default_implicit_of_string s in check (x = x'); let j = `Assoc ["tag", `String "b"] in let s'= Yojson.Safe.to_string j in check (s = s'); let j = `Assoc [] in let s'= Yojson.Safe.to_string j in let x'= Test3j_j.default_implicit_of_string s' in check (x = x'); let x = { Test3j_t.def_imp_constr = `A; } in let s = Test3j_j.string_of_default_implicit x in let x'= Test3j_j.default_implicit_of_string s in check (x = x'); let j = `Assoc ["tag", `String "a"] in let s'= Yojson.Safe.to_string j in check (s = s') let test_json_constr_chained () = section "json constructors chained"; let x = { Test3j_t.first_tag = `A; Test3j_t.second_tag = `A (`B 6); Test3j_t.chained_constr = `A; } in let s = Test3j_j.string_of_chained_constr_record x in let x'= Test3j_j.chained_constr_record_of_string s in check (x = x'); let j = `Assoc [ "first_tag", `String "a"; "second_tag", `List [`String "b"; `Int 6]; ] in let s'= Yojson.Safe.to_string j in check (s = s') let test_wrapping_ints () = section "ocaml wrapping - ints"; let x = Test_lib.Natural.wrap 7 in let json = Testj.string_of_natural x in let x' = Testj.natural_of_string json in check (x = x'); let biniou = Test.string_of_natural x in let x'' = Test.natural_of_string biniou in check (x = x''); try ignore (Testj.natural_of_string "-1"); check false with Failure _ -> () let test_double_wrapping () = section "ocaml wrapping - double wrapping"; let x = Test_lib.Even_natural.wrap (Test_lib.Natural.wrap 10) in let json = Testj.string_of_even_natural x in let x' = Testj.even_natural_of_string json in check (x = x') let test_wrapping_with_validation () = section "ocaml wrapping - with validation"; let x = `Id "" in try ignore (Testv.validate_id [] x); check false with Failure "empty" -> () let test_ignored_wrap () = section "ocaml wrapping - wrap constructor without wrapper"; let x = { Test.some_field = 0 } in try ignore (Testv.validate_no_real_wrap [] x); check false with Failure "passed" -> () let test_biniou_float32 () = section "check length of floats serialized as float32"; let x = { Test.f32 = 1.23456789; Test.f64 = 1.98765432 } in let s = Test.string_of_floats x in let x' = Test.floats_of_string s in check Test.(abs_float (x.f32 -. x'.f32) < 1e-6); check (String.length s = 24) let test_json_float_decimals () = section "print JSON floats with maximum number of decimal places"; let x = { Testj.sqrt2_5 = sqrt 2.; small_2 = 0.000123456789; large_2 = 1234567890123.; } in let s = Testj.string_of_precision x in print_endline s; check (s = "{\"sqrt2_5\":1.4142,\"small_2\":0.00012,\"large_2\":1.2e+12}") let all_tests = [ test_ocaml_internals; test_biniou_missing_field; test_biniou_missing_cell; test_json_missing_field; test_json_missing_cell; test_json_extra_field_warning; test_json_assoc_list; test_json_assoc_array; test_json_int_ocaml_float; test_biniou_correctness; test_json_correctness; test_json_space; test_validators0; test_validators1; test_validators2; test_validators3; test_validators4; test_json_files; test_json_streams; test_raw_json; test_json_constr_mismatch; test_json_constr_nullary; test_json_constr_unary; test_json_constr_implicit; test_json_constr_tag; test_json_constr_multi; test_json_constr_default_tag; test_json_constr_default_constr; test_json_constr_default; test_json_constr_default_implicit; test_json_constr_chained; test_wrapping_ints; test_double_wrapping; test_wrapping_with_validation; test_ignored_wrap; test_biniou_float32; test_json_float_decimals; ] let quality_test () = List.iter (fun f -> try f (); print_endline "Passed." with Failed -> ()) all_tests; match List.rev !errors with [] -> printf "\nSUCCESS\n" | l -> printf "\nThe following tests failed:\n%s\n" (String.concat "\n" l); printf "*** FAILURE ***\n" let () = quality_test () atdgen-1.9.1/test/test_atdgen_type_conv.ml000066400000000000000000000007151273120334000206620ustar00rootroot00000000000000open Sexplib.Std let my_record = Test_type_conv_t.({ fst=123; snd="testing" }) let cmrs : (float Test_type_conv_t.contains_my_record) list = let open Test_type_conv_t in [ `C1 123 ; `C2 123.0 ; `C3 my_record ] let sexps = [my_record |> Test_type_conv_t.sexp_of_my_record] @ (List.map (Test_type_conv_t.sexp_of_contains_my_record sexp_of_float) cmrs) let () = sexps |> sexp_of_list (fun x -> x) |> Sexplib.Sexp.to_string |> print_endline atdgen-1.9.1/test/test_lib.ml000066400000000000000000000017251273120334000161020ustar00rootroot00000000000000type t = Foo of int let fail _ = failwith "not implemented" module Biniou = struct type def = t let def_tag = 0 let write_untagged_def = fail let write_def = fail let string_of_def = fail let get_def_reader = fail let read_def = fail let def_of_string = fail end module Json = struct type def = t let write_def = fail let string_of_def = fail let read_def = fail let def_of_string = fail end module Natural : sig type t = private int val wrap : int -> t val unwrap : t -> int end = struct type t = int let wrap x = if x < 0 then failwith ("Out of bounds number " ^ string_of_int x) else x let unwrap x = x end module Even_natural : sig type t = private Natural.t val wrap : Natural.t -> t val unwrap : t -> Natural.t end = struct type t = Natural.t let wrap (x : Natural.t) = if (x :> int) mod 2 <> 0 then failwith ("Odd number " ^ string_of_int (x :> int)) else x let unwrap x = x end atdgen-1.9.1/test/test_type_conv.atd000066400000000000000000000002441273120334000174750ustar00rootroot00000000000000 type my_record = { fst: int; snd: string; } type 'a contains_my_record = [ | C1 of int | C2 of 'a | C3 of my_record ] atdgen-1.9.1/util/000077500000000000000000000000001273120334000137345ustar00rootroot00000000000000atdgen-1.9.1/util/recompile-deps000077500000000000000000000010721273120334000165720ustar00rootroot00000000000000# -*- sh -*- # Script for working with development versions of atdgen's dependencies. # All git repositories (atd, atdgen, etc.) must exist in the same directory. # Usage (from within atdgen/): . util/recompile-deps # This script is meant to be sourced from the atdgen directory. # It sets the OCAMLPATH variable such that the development versions # of atdgen's dependencies are found first when compiling. atdgen_dir=$(pwd) parent=$atdgen_dir/.. export OCAMLPATH=$parent for x in cppo easy-format atd biniou yojson atdgen; do (cd parent/$x; make clean; make) done