pax_global_header00006660000000000000000000000064122667052060014520gustar00rootroot0000000000000052 comment=f1ebd8ce6b0d620555f687ea4694e08aba97a2f5 atdgen-1.3.1/000077500000000000000000000000001226670520600127645ustar00rootroot00000000000000atdgen-1.3.1/.gitignore000066400000000000000000000012161226670520600147540ustar00rootroot00000000000000*~ *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o *.annot *.run *.opt *.exe META 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 odoc *.mlx.ml *.haux *.html *.htoc *.log *.out *.pdf *.toc manual/atdgen-body.tex manual/atdgen-manual.tex manual/atdgen-manual.txt.iso88591 atdgen-1.3.1/.ocp-indent000066400000000000000000000015721226670520600150320ustar00rootroot00000000000000# 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.3.1/INSTALL000066400000000000000000000041231226670520600140150ustar00rootroot00000000000000 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.3.1/LICENSE000066400000000000000000000025511226670520600137740ustar00rootroot00000000000000Copyright (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.3.1/META.in000066400000000000000000000003121226670520600140360ustar00rootroot00000000000000description = "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.3.1/Makefile000066400000000000000000000176301226670520600144330ustar00rootroot00000000000000VERSION = 1.3.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 install uninstall reinstall all: pp $(MAKE) atdgen.cma atdgen.run opt: pp $(MAKE) atdgen.cmxa $(CMXS) atdgen install: META 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)/ ocamlfind install atdgen META \ $(MLI) $(CMI) $(CMO) $(CMX) $(CMXS) $(O) \ atdgen.cma atdgen.a atdgen.cmxa 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 ocamlfind remove atdgen 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: doc doc: odoc/index.html atdgen$(EXE) cd manual; $(MAKE) odoc/index.html: $(CMI) mkdir -p odoc ocamlfind ocamldoc -d odoc -html \ -t 'Atdgen library documentation' \ -package "$(OCAMLPACKS)" $(DOCSOURCES) # Some testing .PHONY: test really-test test: opt 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 test3b.atd ./atdgen -json 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 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 test3b.mli -package atdgen ocamlfind ocamlopt -c -g test3b.ml -package atdgen ocamlfind ocamlc -c -g test3j.mli -package atdgen ocamlfind ocamlopt -c -g test3j.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 test3b.cmx test3j.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 test3b.mli \ test3j.mli test4.mli test4j.mli testv.mli ./test_atdgen # 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 \ dep atdgen$(EXE) atdgen.run \ 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 \ test3b.mli test3b.ml \ test3j.mli test3j.ml \ test4.mli test4.ml test4j.mli test4j.ml \ ag_doc_lexer.ml rm -rf odoc testdoc cd manual && $(MAKE) clean atdgen-1.3.1/README.md000066400000000000000000000003411226670520600142410ustar00rootroot00000000000000Atdgen uses type definitions in the ATD syntax and generates efficient [JSON](http://json.org) serializers, deserializers and validators for OCaml. Checkout the [tutorial](http://mylifelabs.github.com/atdgen-tutorial.html). atdgen-1.3.1/TODO.md000066400000000000000000000021301226670520600140470ustar00rootroot00000000000000* Website and documentation refresh: move pages to mjambon.com/atdgen, fix broken links pointing to the defunct oss.wink.com, create single sub-site for everything atdgen-related (biniou, yojson, atd, atdgen, atdgen-omake, atdgen-make, documentation) * 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: - 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 - call the executable "atdgen2" if that helps atdgen-1.3.1/ag_biniou.ml000066400000000000000000000026121226670520600152530ustar00rootroot00000000000000(* 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 | `Shared | `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.3.1/ag_doc.ml000066400000000000000000000007641226670520600145410ustar00rootroot00000000000000 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.3.1/ag_doc.mli000066400000000000000000000036501226670520600147070ustar00rootroot00000000000000 (** 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.3.1/ag_doc_lexer.mll000066400000000000000000000062761226670520600161200ustar00rootroot00000000000000{ 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.3.1/ag_error.ml000066400000000000000000000007701226670520600151220ustar00rootroot00000000000000 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.3.1/ag_indent.ml000066400000000000000000000010101226670520600152360ustar00rootroot00000000000000 (* 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.3.1/ag_json.ml000066400000000000000000000031331226670520600147360ustar00rootroot00000000000000(* 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_unwrapped : bool } type json_repr = [ | `Unit | `Bool | `Int | `Float of json_float | `String | `Sum | `Record | `Tuple | `List of json_list | `Option | `Nullable | `Shared | `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 atdgen-1.3.1/ag_main.ml000066400000000000000000000310311226670520600147070ustar00rootroot00000000000000 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) *) ] 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 () = match parse_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 type_aliases = ref None in let name_overlap = ref (get_default_name_overlap ()) in let set_opens s = let l = Str.split (Str.regexp " *, *\\| +") s in opens := List.rev_append l !opens in let options = [ "-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."; "-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) && !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 ~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 ~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 ~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.3.1/ag_mapping.ml000066400000000000000000000114131226670520600154200ustar00rootroot00000000000000open 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) | `Shared of (loc * loc_id * ('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, _, _, _) | `Shared (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) | `Shared (loc, id, x, a, b) -> `Shared (loc, id, 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 atdgen-1.3.1/ag_ob_emit.ml000066400000000000000000001251441226670520600154120ustar00rootroot00000000000000(* 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 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" | `Shared (loc, id, x, `Shared _, `Shared) -> "Bi_io.shared_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 ")"; ] | `Shared (loc, id, x, `Shared kind, `Shared) -> let suffix = match kind with `Flat -> "" | `Ref -> "_ref" in [ `Line (sprintf "Ag_ob_run.write_%sshared%s shared%s (" un suffix id); `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 deref fields = let maybe_constant = List.for_all (function (_, _, Some _, _, _) -> true | _ -> false) fields in let _, init_fields = List.fold_right ( fun (x, name, default, opt, unwrap) (maybe_constant, l) -> let maybe_constant, v = match default with None -> assert (not opt); (* The initial value is a float because the record may be represented as a double_array (unboxed floats). Float values work in all cases. *) let v = "Obj.magic 0.0" in maybe_constant, v | Some s -> false, (if maybe_constant then sprintf "(fun x -> x) (%s)" s else s) in (maybe_constant, `Line (sprintf "%s = %s;" name v) :: l) ) fields (maybe_constant, []) 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 init_val = [ `Line "{"; `Block init_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_val, init_bits, set_bit, check_bits 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 ?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 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 ~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 ~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 ~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 ~tagged:false x); `Line ")"; ] | list_kind, `Table -> (* Support table format and regular array format *) let body1 = make_table_reader 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 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 x); `Line ")"; `Block [ `Line "ib"]; ]; `Line ")" ]; `Line "| _ -> Ag_ob_run.read_error_at ib"; ] ] in wrap_body ~tagged Bi_io.num_variant_tag body | `Shared (loc, id, x, `Shared kind, `Shared) -> let body = match kind with `Flat -> (match deref x with `Record (loc, a, `Record o, `Record) -> (match o with `Record -> () | `Object -> error loc "OCaml objects are not supported" ); make_record_reader ~shared_id:id deref ~tagged type_annot a o | _ -> error loc "Only record types can use sharing \ (or use )" ) | `Ref -> let read_value = make_reader deref ~tagged:true x in [ `Line (sprintf "Ag_ob_run.read_shared shared%s (" id); `Block read_value; `Line ") ib"; ] in wrap_body ~tagged Bi_io.shared_tag body | `Wrap (loc, x, `Wrap o, `Wrap) -> let simple_reader = make_reader deref ~tagged 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 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 v); `Line ") ib"; ]; `Line (sprintf ")%s)" (Ag_ox_emit.insert_annot type_annot)); ]; ] and make_record_reader ?shared_id deref ~tagged type_annot a record_kind = let fields = get_fields deref a in let init_val, init_bits, set_bit, check_bits = study_record deref fields in let build share body = [ `Line (sprintf "let %s =" (Ag_ox_emit.opt_annot_def type_annot "x")); `Block init_val; `Line "in"; `Inline share; `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 "Ag_ob_run.identity x" ] in let loop body = match shared_id with None -> build [] body | Some id -> let share = [ `Line (sprintf "if Bi_io.read_tag ib <> %i then \ Ag_ob_run.read_error_at ib;" Bi_io.record_tag); `Line (sprintf "Bi_share.Rd.put ib.Bi_inbuf.i_shared \ (pos, shared%s) (Obj.repr x);" id); ] in [ `Line "let pos = ib.Bi_inbuf.i_offs + ib.Bi_inbuf.i_pos in"; `Line "let offset = Bi_vint.read_uvint ib in"; `Line "if offset = 0 then"; `Block (build share body); `Line "else"; `Block [ `Line (sprintf "Obj.obj (Bi_share.Rd.get ib.Bi_inbuf.i_shared \ (pos - offset, shared%s))" id) ] ] 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 f_value); `Line ") ib" ] in `Inline [ `Line (sprintf "| %i ->" (Bi_io.hash_name x.f_name)); `Block [ `Line "let v ="; `Block (wrap read_value); `Line "in"; `Line (sprintf "Obj.set_field (Obj.repr x) %i (Obj.repr v);" i); `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 loop body and make_tuple_reader deref ~tagged 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 ~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 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_val, init_bits, set_bit, check_bits = study_record 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 x.f_value); `Line ")"; `Block [ `Line "tag" ] ]; `Line "in"; `Line "(fun x ib ->"; `Block [ `Line (sprintf "Obj.set_field (Obj.repr x) %i \ (Obj.repr (read ib)))" i ) ] ] ] ) (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_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 x 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 "let x ="; `Block init_val; `Line "in"; `Line "for i = 0 to Array.length readers - 1 do"; `Block [ `Line "readers.(i) x ib" ]; `Line "done;"; `Line "a.(row) <- x"; ]; `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 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 ?type_annot x in let read_expr = make_reader deref ~tagged:true ?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" module S = Set.Make (String) let extract_loc_ids_from_expr x acc = Atd_ast.fold (fun x acc -> match x with (`Shared (_, _, a)) -> let id = Atd_annot.get_field (fun s -> Some s) "" ["share"] "id" a in if id <> "" then S.add id acc else acc | _ -> acc) x acc let extract_loc_ids l = let set = List.fold_left ( fun acc (`Type (loc, (name, param, a), x)) -> extract_loc_ids_from_expr x acc ) S.empty l in S.elements set let make_shared_id_defs atd_module = let buf = Buffer.create 200 in let l = extract_loc_ids atd_module in List.iter (fun id -> bprintf buf "let shared%s = Bi_share.create_type_id ()\n" id) l; Buffer.contents buf let make_ocaml_biniou_impl ~with_create ~original_types buf deref defs = (*bprintf buf "%s\n" (make_shared_id_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 ~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) -> 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_typedefs ocaml_impl_misc 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 ( bprintf buf "%s\n" ocaml_impl_misc; make_ocaml_biniou_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 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 m1 = if all_rec then [ (true, m0) ] else Atd_util.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 = Atd_util.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 ~target:`Biniou ~type_aliases (head, m1) in let ocaml_impl_misc = make_shared_id_defs m0 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 ocaml_impl_misc (Ag_mapping.make_deref defs) defs in Ag_ox_emit.write_ocaml out mli ml atdgen-1.3.1/ag_ob_mapping.ml000066400000000000000000000133241226670520600161030ustar00rootroot00000000000000open 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) -> let ocaml_t = `Shared (Ag_ocaml.get_ocaml_shared a) in let biniou_t = `Shared in let id = Atd_annot.get_field (fun s -> Some s) "" ["share"] "id" a in if id = "" then error loc "bug: missing or empty share.id annotation"; `Shared (loc, id, mapping_of_expr x, ocaml_t, biniou_t) | `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.3.1/ag_ob_run.ml000066400000000000000000000206521226670520600152560ustar00rootroot00000000000000 (* 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 write_untagged_shared_ref id write ob x = let pos = ob.Bi_outbuf.o_offs + ob.Bi_outbuf.o_len in let offset = Bi_share.Wr.put ob.Bi_outbuf.o_shared (x, id) pos in Bi_vint.write_uvint ob offset; if offset = 0 then write ob !x let write_shared_ref id write ob x = Bi_io.write_tag ob Bi_io.shared_tag; write_untagged_shared_ref id write ob x let write_untagged_shared id write ob x = let pos = ob.Bi_outbuf.o_offs + ob.Bi_outbuf.o_len in let offset = Bi_share.Wr.put ob.Bi_outbuf.o_shared (x, id) pos in Bi_vint.write_uvint ob offset; if offset = 0 then write ob x let write_shared id write ob x = Bi_io.write_tag ob Bi_io.shared_tag; write_untagged_shared id write ob x let read_shared id read ib = let pos = ib.Bi_inbuf.i_offs + ib.Bi_inbuf.i_pos in let offset = Bi_vint.read_uvint ib in if offset = 0 then let r = ref (Obj.magic 0) in Bi_share.Rd.put ib.Bi_inbuf.i_shared (pos, id) (Obj.repr r); r := read ib; r else Obj.obj (Bi_share.Rd.get ib.Bi_inbuf.i_shared (pos - offset, id)) 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 = 42 } 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.3.1/ag_ob_spe.ml000066400000000000000000000003531226670520600152350ustar00rootroot00000000000000 (* 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.3.1/ag_ocaml.ml000066400000000000000000000532531226670520600150700ustar00rootroot00000000000000(* 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_shared = [ `Flat | `Ref ] 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 | `Shared of atd_ocaml_shared | `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 ocaml_shared_of_string s : atd_ocaml_shared option = match s with "flat" -> Some `Flat | "ref" -> Some `Ref | s -> None 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_shared an = Atd_annot.get_field ocaml_shared_of_string `Flat ["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) -> (match get_ocaml_shared a with `Flat -> map_expr x | `Ref -> `Name ("Pervasives.ref", [map_expr x]) ) | `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]) | `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 rec format_module_item 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 prepend_ocamldoc_comment doc part123 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 is_rec (l : ocaml_module_body) = match l with x :: l -> format_module_item true x :: List.map (fun x -> format_module_item false x) l | [] -> [] let format_module_body is_rec (l : ocaml_module_body) = List ( ("", "", "", rlist), format_module_items is_rec l ) let format_module_bodies (l : (bool * ocaml_module_body) list) = List.flatten (List.map (fun (is_rec, x) -> format_module_items 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 ~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 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.3.1/ag_oj_emit.ml000066400000000000000000001120101226670520600154060ustar00rootroot00000000000000(* 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. *) force_defaults : bool; preprocess_input : string option; (* intended for UTF-8 validation *) } 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 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 get_assoc_type deref loc x = match deref x with `Tuple (loc2, [| k; v |], `Tuple, `Tuple) -> (match deref k.cel_value with `String _ -> () | _ -> error loc "Due to keys must be strings"); 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 let get_fields p a = List.map ( fun x -> let ocaml_fname, ocaml_default, json_fname, optional, unwrapped = match x.f_arepr, x.f_brepr with `Field o, `Field j -> 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 p.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, j.Ag_json.json_fname, optional, j.Ag_json.json_unwrapped | _ -> assert false in (x, ocaml_fname, ocaml_default, json_fname, optional, unwrapped) ) (Array.to_list 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 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 (loc, a, `Sum x, `Sum) -> 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_writer p tick x)) a ) ) ] in [ `Annot ("fun", `Line "fun ob x ->"); `Block body ] | `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 x = 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 x); `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 ")"; ] | `Shared (loc, _, _, _, _) -> error loc "Sharing is not supported by the JSON interface" | `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 x : 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 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_record_writer p a record_kind = let dot = match record_kind with `Record -> "." | `Object -> "#" in 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_fields = List.map ( fun (x, ocaml_fname, ocaml_default, json_fname, optional, unwrapped) -> let f_value = if unwrapped then Ag_ocaml.unwrap_option p.deref x.f_value else x.f_value in let write_field_tag = sprintf "Bi_outbuf.add_string ob %S;" (make_json_string json_fname ^ ":") in let app v = [ `Inline sep; `Line write_field_tag; `Line "("; `Block (make_writer p f_value); `Line ")"; `Block [`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 let l = if unwrapped then [ `Line (sprintf "(match %s with None -> () | Some x ->" v); `Block (app "x"); `Line ");" ] else if optional && not p.force_defaults then [ `Line (sprintf "if %s != %s then (" v (unopt ocaml_default)); `Block (app v); `Line ");" ] else app v in `Inline l ) fields in [ `Line "Bi_outbuf.add_char ob '{';"; `Line "let is_first = ref true in"; `Inline write_fields; `Line "Bi_outbuf.add_char ob '}';"; ] let study_record deref fields = let maybe_constant = List.for_all (function (_, _, Some _, _, _, _) -> true | _ -> false) fields in let _, init_fields = List.fold_right ( fun (x, oname, default, jname, opt, unwrap) (maybe_constant, l) -> let maybe_constant, v = match default with None -> assert (not opt); (* The initial value is a float because the record may be represented as a double_array (unboxed floats). Float values work in all cases. *) let v = "Obj.magic 0.0" in maybe_constant, v | Some s -> false, (if maybe_constant then sprintf "(fun x -> x) (%s)" s else s) in (maybe_constant, `Line (sprintf "%s = %s;" oname v) :: l) ) fields (maybe_constant, []) in let n, mapping = List.fold_left ( fun (i, acc) (x, oname, default, jname, 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 init_val = [ `Line "{"; `Block init_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, oname, default, jname, opt, unwrap) acc -> if default = None && 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_oj_run.missing_fields %s %s;" bool_expr bit_fields field_names) ] in init_val, init_bits, set_bit, check_bits 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 (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 x = 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 x); `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)" ] ] | `Shared (loc, _, _, _, _) -> error loc "Sharing is not supported by the JSON interface" | `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_record_reader p type_annot loc a record_kind = let fields = get_fields p a in let init_val, init_bits, set_bit, check_bits = study_record p.deref fields in let read_field = let a = Array.of_list fields in let cases = Array.mapi ( fun i (x, ocaml_fname, ocaml_default, json_fname, opt, unwrapped) -> 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 expr = [ `Line "let v ="; `Block (wrap read_value); `Line "in"; `Line (sprintf "Obj.set_field (Obj.repr x) %i (Obj.repr v);" i); `Inline (set_bit i); ] in let opt_expr = if opt then [ `Line "if not (Yojson.Safe.read_null_if_possible p lb) then ("; `Block expr; `Line ")" ] else expr in (json_fname, opt_expr) ) a 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 [ `Line "Yojson.Safe.read_space p lb;"; `Line "Yojson.Safe.read_lcurl p lb;"; `Line (sprintf "let %s =" (Ag_ox_emit.opt_annot type_annot "x")); `Block init_val; `Line "in"; `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 check_bits; `Line "Ag_oj_run.identity x"; ]; `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_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 !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 ~with_create ~force_defaults ~preprocess_input ~original_types buf deref defs = let p = { deref = deref; std = std; unknown_field_handler = unknown_field_handler; force_defaults = force_defaults; preprocess_input; } 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) -> 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 ~force_defaults ~preprocess_input ~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_json_impl ~std ~unknown_field_handler ~with_create ~force_defaults ~preprocess_input ~original_types buf deref defs; Buffer.contents buf let make_ocaml_files ~opens ~with_typedefs ~with_create ~with_fundefs ~all_rec ~std ~unknown_field_handler ~pos_fname ~pos_lnum ~type_aliases ~force_defaults ~preprocess_input ~name_overlap 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 m1 = if all_rec then [ (true, m0) ] else Atd_util.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 = Atd_util.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 ~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 ~force_defaults ~preprocess_input ~original_types ocaml_typedefs (Ag_mapping.make_deref defs) defs in Ag_ox_emit.write_ocaml out mli ml atdgen-1.3.1/ag_oj_mapping.ml000066400000000000000000000130251226670520600161110ustar00rootroot00000000000000open 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 { 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_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.3.1/ag_oj_run.ml000066400000000000000000000130151226670520600152610ustar00rootroot00000000000000(* Runtime library for JSON *) open Printf exception Error of string (* Error messages *) let error s = raise (Error s) 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_item ob l = Bi_outbuf.add_char ob '{'; list_iter ( fun ob (k, v) -> Yojson.Safe.write_string 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_item ob l = Bi_outbuf.add_char ob '{'; array_iter ( fun ob (k, v) -> Yojson.Safe.write_string 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_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_fields read [] p lb let read_assoc_list read_item p lb = List.rev (read_assoc_list_rev 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_item p lb = array_of_rev_list (read_assoc_list_rev 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 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)) let invalid_variant_tag s = error (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 = 42 } 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.3.1/ag_ov_emit.ml000066400000000000000000000326621226670520600154400ustar00rootroot00000000000000(* 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 -> let s = x.def_name in if s <> "" && s.[0] <> '_' && x.def_value <> None then ( if with_create 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 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 ")"; ] ] (* ('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 ")"; ] | `Shared (loc, _, _, _, (v, shallow)) -> if shallow then opt_validator v else error loc "Shared values requiring validation of their children \ nodes are not supported" | `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) -> 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 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 m1 = if all_rec then [ (true, m0) ] else Atd_util.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 = Atd_util.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 ~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.3.1/ag_ov_mapping.ml000066400000000000000000000240171226670520600161300ustar00rootroot00000000000000open 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) -> let ocaml_t = `Shared (Ag_ocaml.get_ocaml_shared an) in let id = Atd_annot.get_field (fun s -> Some s) "" ["share"] "id" an in if id = "" then error loc "bug: missing or empty share.id annotation"; `Shared (loc, id, mapping_of_expr is_shallow x, ocaml_t, v2 an x0) | `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.3.1/ag_ov_run.ml000066400000000000000000000011041226670520600152710ustar00rootroot00000000000000let 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.3.1/ag_ox_emit.ml000066400000000000000000000172671226670520600154460ustar00rootroot00000000000000(* 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, _, _) | `Shared (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 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 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.3.1/ag_string_match.ml000066400000000000000000000165551226670520600164630ustar00rootroot00000000000000 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.3.1/ag_string_match.mli000066400000000000000000000044671226670520600166330ustar00rootroot00000000000000 (* 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.3.1/ag_util.ml000066400000000000000000000135351226670520600147510ustar00rootroot00000000000000 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 read ic = let ib = Bi_inbuf.from_channel ?len ?shrlen ic in read ib let from_file ?len ?shrlen read fname = input_file fname (fun ic -> from_channel ?len ?shrlen read ic) let to_channel ?len ?shrlen 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 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 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.3.1/ag_util.mli000066400000000000000000000357751226670520600151340ustar00rootroot00000000000000(** 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 initial length of the table used to store shared values. *) 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 initial length of the table used to store shared values. *) 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 initial length of the table used to store shared values. *) 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 initial length of the table used to store shared values. *) 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. *) 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.3.1/ag_validate.ml000066400000000000000000000017751226670520600155700ustar00rootroot00000000000000(* Mapping from ATD to "validate" *) 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 get_validator an = Atd_annot.get_field (fun s -> Some (Some s)) None ["ocaml"] "validator" an atdgen-1.3.1/ag_xb_emit.ml000066400000000000000000000104371226670520600154210ustar00rootroot00000000000000(* 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, _, _) | `Shared (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.3.1/benchmark.ml000066400000000000000000000106441226670520600152550ustar00rootroot00000000000000 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.3.1/example/000077500000000000000000000000001226670520600144175ustar00rootroot00000000000000atdgen-1.3.1/example/Makefile000066400000000000000000000003321226670520600160550ustar00rootroot00000000000000.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.3.1/example/README000066400000000000000000000012451226670520600153010ustar00rootroot00000000000000 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.3.1/example/example.sh000066400000000000000000000023031226670520600164040ustar00rootroot00000000000000#! /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.3.1/example/format_v1.atd000066400000000000000000000001741226670520600170110ustar00rootroot00000000000000(* Older version of an imagined data format *) type t = { a : int option; b : bool; ?c : int option; ~d : float; } atdgen-1.3.1/example/format_v2.atd000066400000000000000000000005531226670520600170130ustar00rootroot00000000000000(* 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.3.1/example/upgrade_demo.ml000066400000000000000000000024021226670520600174020ustar00rootroot00000000000000open 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.3.1/manual/000077500000000000000000000000001226670520600142415ustar00rootroot00000000000000atdgen-1.3.1/manual/Makefile000066400000000000000000000026471226670520600157120ustar00rootroot00000000000000# `make pdf' requires pdflatex and builds readme.pdf # `make txt' requires hevea and builds readme.txt # `make html' requires hevea and builds readme.html TEXFILES = atd-annot.tex atdgen-manual.tex atdgen-body.tex .PHONY: all pdf txt html clean all: pdf txt html pdf: atdgen-manual.pdf txt: atdgen-manual.txt html: atdgen-manual.html atdgen-manual.tex: ../ag_version.ml atdgen-manual.mlx OCAMLPATH=../..:$$OCAMLPATH \ camlmix atdgen-manual.mlx -o atdgen-manual.tex atdgen-body.tex: ../ag_version.ml macros.ml atdgen-body.mlx OCAMLPATH=../..:$$OCAMLPATH \ camlmix atdgen-body.mlx -o atdgen-body.tex atdgen-manual.txt: $(TEXFILES) rm -f *.aux hevea -fix -text atdgen-manual mv atdgen-manual.txt atdgen-manual.txt.iso88591 iconv -f ISO_8859-1 -t UTF-8 \ < atdgen-manual.txt.iso88591 > ../atdgen-manual.txt atdgen-manual.html: $(TEXFILES) rm -f *.aux hevea -fix atdgen-manual sed -i '/<\/STYLE>/ r hevea-insert1.html' atdgen-manual.html sed -i '// r hevea-insert2.html' atdgen-manual.html sed -i 's/<\/BLOCKQUOTE><\/BODY>/<\/BLOCKQUOTE>\n<\/BODY>/' \ atdgen-manual.html sed -i '// r hevea-insert3.html' atdgen-manual.html atdgen-manual.pdf: $(TEXFILES) pdflatex atdgen-manual pdflatex atdgen-manual pdflatex atdgen-manual clean: rm -f *.aux *.toc *.log *.out *.haux *.htoc *.fls \ atdgen-body.tex atdgen-manual.tex atdgen-manual.pdf \ atdgen-manual.txt atdgen-manual.html \ *.mlx.ml atdgen-1.3.1/manual/atd-annot.tex000066400000000000000000000004101226670520600166430ustar00rootroot00000000000000% requires \usepackage{ifthen} \newcommand\annotpar[1]{% \paragraph{#1}$ $ } \newcommand\annotposition{\textit{Position}: } \newcommand\annotvalues{\textit{Values}: } \newcommand\annotsemantics{\textit{Semantics}: } \newcommand\annotexample{\textit{Example}: } atdgen-1.3.1/manual/atdgen-body.mlx000066400000000000000000000612461226670520600171710ustar00rootroot00000000000000% -*- latex -*- ## #use "topfind";; #require "caml2html";; #require "atd";; #require "unix";; #use "../ag_version.ml";; #use "macros.ml";; ## \section{Introduction} Atdgen is a command-line program that takes as input type definitions in the \href{http://mjambon.com/atd}{ATD} syntax and produces OCaml code suitable for data serialization and deserialization. Two data formats are currently supported, these are \href{http://mjambon.com/biniou.html}{biniou} and \href{http://json.org/}{JSON}. Atdgen-biniou and Atdgen-json will refer to Atdgen used in one context or the other. Atdgen was designed with efficiency and durability in mind. Software authors are encouraged to use Atdgen directly and to write tools that may reuse part of Atdgen's source code. Atdgen uses the following packages that were developed in conjunction with Atdgen: \begin{itemize} \item \texttt{atd}: parser for the syntax of type definitions \item \texttt{biniou}: parser and printer for biniou, a binary extensible data format \item \href{http://mjambon.com/yojson.html}{\texttt{yojson}}: parser and printer for JSON, a widespread text-based data format \end{itemize} Atdgen does not use Camlp4. \section{Command-line usage} \subsection{Command-line help} \begin{verbatim} $ atdgen -help \end{verbatim} %$ ## shell "cd ..; ./atdgen -help" ## \subsection{Atdgen-biniou example} \begin{verbatim} $ atdgen -t example.atd $ atdgen -b example.atd \end{verbatim} %$ Input file \texttt{example.atd}: ## atdgen_biniou_mli ~prefix:"example" "is used to produce files \\texttt{example\\_t.mli}, \\texttt{example\\_t.ml}, \\texttt{example\\_b.mli} and \\texttt{example\\_b.ml}. This is \\texttt{example\\_b.mli}:" ## type profile = { id : string; email : string; ~email_validated : bool; name : string; ?real_name : string option; ~about_me : string list; ?gender : gender option; ?date_of_birth : date option; } type gender = [ Female | Male ] type date = { year : int; month : int; day : int; } ## () ## Module \texttt{Example\_t} (files \texttt{example\_t.mli} and \texttt{example\_t.ml}) contains all OCaml type definitions that can be used independently from Biniou or JSON. For convenience, these definitions are also made available from the \texttt{Example\_b} module whose interface is shown above. Any type name, record field name or variant constructor can be referred to using either module. For example, the OCaml expressions \texttt{((x : Example\_t.date) : Example\_b.date)} and \texttt{x.Example\_t.year = x.Example\_b.year} are both valid. \subsection{Atdgen-json example} \begin{verbatim} $ atdgen -t example.atd $ atdgen -j example.atd \end{verbatim} %$ Input file \texttt{example.atd}: ## atdgen_json_mli ~prefix:"example" "is used to produce files \\texttt{example\\_t.mli}, \\texttt{example\\_t.ml}, \\texttt{example\\_j.mli} and \\texttt{example\\_j.ml}. This is \\texttt{example\\_j.mli}:" ## type profile = { id : string; email : string; ~email_validated : bool; name : string; ?real_name : string option; ~about_me : string list; ?gender : gender option; ?date_of_birth : date option; } type gender = [ Female | Male ] type date = { year : int; month : int; day : int; } ## () ## Module \texttt{Example\_t} (files \texttt{example\_t.mli} and \texttt{example\_t.ml}) contains all OCaml type definitions that can be used independently from Biniou or JSON. For convenience, these definitions are also made available from the \texttt{Example\_j} module whose interface is shown above. Any type name, record field name or variant constructor can be referred to using either module. For example, the OCaml expressions \texttt{((x : Example\_t.date) : Example\_j.date)} and \texttt{x.Example\_t.year = x.Example\_j.year} are both valid. \subsection{Validator example} \begin{verbatim} $ atdgen -t example.atd $ atdgen -v example.atd \end{verbatim} Input file \texttt{example.atd}: ## atdgen_validate_ml ~prefix:"example" "is used to produce files \\texttt{example\\_t.mli}, \\texttt{example\\_t.ml}, \\texttt{example\\_v.mli} and \\texttt{example\\_v.ml}. This is \\texttt{example\\_v.ml}, showing how the user-specified validators are used:" ## type month = int type day = int type date = { year : int; month : month; day : day; } ## () ## \section{Default type mapping} The following table summarizes the default mapping between ATD types and OCaml, biniou and JSON data types. For each language more representations are available and are detailed in the next section of this manual. \makebox[\textwidth]{% \begin{tabular}{llll} \hline ATD & OCaml & Biniou & JSON \\ \hline \tt unit & \tt unit & unit & null \\ \tt bool &\tt bool & bool & boolean \\ \tt int & \tt int & svint & number (int) \\ \tt float & \tt float & float64 & number (not int) \\ \tt string & \tt string & string & string \\ \tt option & \tt option & numeric variants (tag 0) & None/Some variants \\ \tt list & \tt list & array & array \\ \tt shared & no wrapping & shared & not implemented \\ variants & polymorphic variants & regular variants & variants \\ record & record & record & object \\ tuple & tuple & tuple & tuple \\ \hline \end{tabular}% } Notes: \begin{itemize} \item The JSON null value serves only as the unit value and is useful in practice only for instanciating parametrized types with ``nothing''. Option types have a distinct representation that does not use the null value. \item OCaml floats are written to JSON numbers with either a decimal point or an exponent such that they are distinguishable from ints, even though the JSON standard does not require a distinction between the two. \item The optional values of record fields denoted in ATD by a question mark are unwrapped or omitted in both biniou and JSON. \item JSON option values and JSON variants are represented in standard JSON ({\tt atdgen -j -j-std}) by a single string e.g. {\tt "None"} or a pair in which the first element is the name (constructor) e.g. {\tt ["Some", 1234]}. Yojson also provides a specific syntax for variants using edgy brackets: {\tt <"None">}, {\tt <"Some": 1234>}. \item Biniou field names and variant names other than the option types use the hash of the ATD field or variant name and cannot currently be overridden by annotations. \item JSON tuples in standard JSON ({\tt atdgen -j -j-std}) use the array notation e.g. {\tt ["ABC", 123]}. Yojson also provides a specific syntax for tuples using parentheses, e.g. {\tt ("ABC", 123)}. \item Types defined as {\tt abstract} are defined in another module. \end{itemize} \section{ATD Annotations} ## annot_section "biniou" ## ## annot_field "repr" ## \annotpar{Integers} \annotposition after \texttt{int} type \annotvalues \texttt{svint} (default), \texttt{uvint}, \texttt{int8}, \texttt{int16}, \texttt{int32}, \texttt{int64} \annotsemantics specifies an alternate type for representing integers. The default type is \texttt{svint}. The other integers types provided by biniou are supported by Atdgen-biniou. They have to map to the corresponding OCaml types in accordance with the following table: \begin{tabular}{lll} \hline Biniou type & Supported OCaml type & OCaml value range \\ \hline \tt svint & \tt int & \tt min\_int $\dots$ max\_int \\ \tt uvint & \tt int & {\tt 0 $\dots$ max\_int}, {\tt min\_int $\dots$ -1} \\ \tt int8 & \tt char & \tt '\bs000' $\dots$ '\bs255' \\ \tt int16 & \tt int & \tt 0 $\dots$ 65535 \\ \tt int32 & \tt int32 & \tt Int32.min\_int $\dots$ Int32.max\_int \\ \tt int64 & \tt int64 & \tt Int64.min\_int $\dots$ Int64.max\_int \\ \hline \end{tabular} In addition to the mapping above, if the OCaml type is \texttt{int}, any biniou integer type can be read into OCaml data regardless of the declared biniou type. \annotexample ## atdgen () ## type t = { id : int ; data : string list; } ## () ## \annotpar{Floating-point numbers} \annotposition after \texttt{float} type \annotvalues \texttt{float64} (default), \texttt{float32} \annotsemantics \texttt{float32} allows for a shorter serialized representation of floats, using 4 bytes instead of 8, with reduced precision. OCaml floats always use 8 bytes, though. \annotexample ## atdgen () ## type t = { lat : float ; lon : float ; } ## () ## \annotpar{Arrays and tables} \annotposition applies to lists of records \annotvalues \texttt{array} (default), \texttt{table} \annotsemantics \texttt{table} uses biniou's table format instead of a regular array for serializing OCaml data into biniou. Both formats are supported for reading into OCaml data regardless of the annotation. The table format allows \annotexample ## atdgen () ## type item = { id : int; data : string list; } type items = item list ## () ## ## annot_section "json" ## ## annot_field "name" ## \annotposition after field name or variant name \annotvalues any string making a valid JSON string value \annotsemantics specifies an alternate object field name or variant name to be used by the JSON representation. \annotexample ## atdgen_json () ## type color = [ Black | White | Grey ] type profile = { id : int; username : string; background_color : color; } ## () ## A valid JSON object of the \texttt{profile} type above is: \begin{verbatim} { "ID": 12345678, "username": "kimforever", "background_color": "black" } \end{verbatim} ## annot_field "repr" ## \annotpar{Association lists} \annotposition after \texttt{(string * \_) list} type \annotvalues \texttt{object} \annotsemantics uses JSON's object notation to represent association lists. \annotexample ## atdgen () ## type counts = (string * int) list ## () ## A valid JSON object of the \texttt{counts} type above is: \begin{verbatim} { "bob": 3, "john": 1408, "mary": 450987, "peter": 93087 } \end{verbatim} Without the annotation \texttt{}, the data above would be represented as: \begin{verbatim} [ [ "bob", 3 ], [ "john", 1408 ], [ "mary", 450987 ], [ "peter", 93087 ] ] \end{verbatim} \annotpar{Floats} \annotposition after \texttt{float} type \annotvalues \texttt{int} \annotsemantics specifies a float value that must be rounded to the nearest integer and represented in JSON without a decimal point nor an exponent. \annotexample ## atdgen () ## type unixtime = float ## () ## ## annot_section "ocaml" ## ## annot_field "predef" ## \annotposition left-hand side of a type definition, after the type name \annotvalues none, \texttt{true} or \texttt{false} \annotsemantics this flag indicates that the corresponding OCaml type definition must be omitted. \annotexample ## ocaml () ## (* Some third-party OCaml code *) type message = { from : string; subject : string; body : string; } ## () ## ## atdgen () ## (* Our own ATD file used for making message_of_string and string_of_message functions. *) type message = { from : string; subject : string; body : string; } ## () ## ## annot_field "mutable" ## \annotposition after a record field name \annotvalues none, \texttt{true} or \texttt{false} \annotsemantics this flag indicates that the corresponding OCaml record field is mutable. \annotexample ## atdgen () ## type counter = { total : int; errors : int; } ## () ## translates to the following OCaml definition: ## ocaml () ## type counter = { mutable total : int; mutable errors : int; } ## () ## ## annot_field "default" ## \annotposition after a record field name marked with a \texttt{\~{}} symbol or at the beginning of a tuple field. \annotvalues any valid OCaml expression \annotsemantics specifies an explicit default value for a field of an OCaml record or tuple, allowing that field to be omitted. \annotexample ## atdgen () ## type color = [ Black | White | Rgb of (int * int * int) ] type ford_t = { year : int; ~color : color; } type point = (int * int * : int) ## () ## ## annot_field "from" ## \annotposition left-hand side of a type definition, after the type name \annotvalues OCaml module name without the \texttt{\_t}, \texttt{\_b}, \texttt{\_j} or \texttt{\_v} suffix. This can be also seen as the name of the original ATD file, without the \texttt{.atd} extension and capitalized like an OCaml module name. \annotsemantics specifies the base name of the OCaml modules where the type and values coming with that type are defined. It is useful for ATD types defined as \texttt{abstract} and for types annotated as predefined using the annotation \texttt{}. In both cases, the missing definitions must be provided by modules composed of the base name and the standard suffix assumed by Atdgen which is \texttt{\_t}, \texttt{\_b}, \texttt{\_j} or \texttt{\_v}. \annotexample First input file \texttt{part1.atd}: ## atdgen () ## type point = { x : int; y : int } ## () ## Second input file \texttt{part2.atd} depending on the first one: ## atdgen () ## type point = abstract type points = point list ## () ## ## annot_field "module" ## In most cases since Atdgen 1.2.0 \texttt{module} annotations are deprecated in favor of \texttt{from} annotations previously described. \annotposition left-hand side of a type definition, after the type name \annotvalues OCaml module name \annotsemantics specifies the OCaml module where the type and values coming with that type are defined. It is useful for ATD types defined as \texttt{abstract} and for types annotated as predefined using the annotation \texttt{}. In both cases, the missing definitions can be provided either by globally opening an OCaml module with an OCaml directive or by specifying locally the name of the module to use. The latter approach is recommended because it allows to create type and value aliases in the OCaml module being generated. It results in a complete module signature regardless of the external nature of some items. \annotexample Input file \texttt{example.atd}: ## atdgen () ## type document = abstract type color = [ Black | White ] type point = { x : float; y : float; } ## () ## gives the following OCaml type definitions (file \texttt{example.mli}): ## ocaml () ## type document = Doc.document type color = Color.color = Black | White type point = Point.point = { x: float; y: float } ## () ## Now for instance \texttt{Example.Black} and \texttt{Color.Black} can be used interchangeably in other modules. ## annot_field "t" ## \annotposition left-hand side of a type definition, after the type name. Must be used in conjunction with a \texttt{module} field. \annotvalues OCaml type name as found in an external module. \annotsemantics This option allows to specify the name of an OCaml type defined in an external module. It is useful when the type needs to be renamed because its original name is already in use or not enough informative. Typically we may want to give the name \texttt{foo} to a type originally defined in OCaml as \texttt{Foo.t}. \annotexample ## atdgen () ## type foo = abstract type bar = abstract type t = abstract ## () ## allows local type names to be unique and gives the following OCaml type definitions: ## ocaml () ## type foo = Foo.t type bar = Bar.t type t = Baz.t ## () ## ## annot_field ~label:"field-prefix" "field\\_prefix" ## \annotposition record type expression \annotvalues any string making a valid prefix for OCaml record field names \annotsemantics specifies a prefix to be prepended to each field of the OCaml definition of the record. Overridden by alternate field names defined on a per-field basis. \annotexample ## atdgen () ## type point2 = { x : int; y : int; } ## () ## gives the following OCaml type definition: ## ocaml () ## type point2 = { p2_x : int; p2_y : int; } ## () ## ## annot_field "name" ## \annotposition after record field name or variant name \annotvalues any string making a valid OCaml record field name or variant name \annotsemantics specifies an alternate record field name or variant names to be used in OCaml. \annotexample ## atdgen () ## type color = [ Black | White | Grey ] type profile = { id : int; username : string; } ## () ## gives the following OCaml type definitions: ## ocaml () ## type color = [ `Grey0 | `Grey100 | `Grey50 ] type profile = { profile_id : int; username : string; } ## () ## ## annot_field "repr" ## \annotpar{Integers} \annotposition after \texttt{int} type \annotvalues \texttt{char}, \texttt{int32}, \texttt{int64}, \texttt{float} \annotsemantics specifies an alternate type for representing integers. The default type is \texttt{int}, but \texttt{char}, \texttt{int32}, \texttt{int64} or \texttt{float} can be used instead. The three types \texttt{char}, \texttt{int32} and \texttt{int64} are supported by both Atdgen-biniou and Atdgen-json but Atdgen-biniou currently requires that they map to the corresponding fixed-width types provided by the biniou format. The type \texttt{float} is only supported in conjunction with JSON and is useful when an OCaml float is used to represent an integral value, such as a time in seconds returned by \texttt{Unix.time()}. When converted into JSON, floats are rounded to the nearest integer. \annotexample ## atdgen () ## type t = { id : int ; data : string list; } ## () ## \annotpar{Lists and arrays} \annotposition after a \texttt{list} type \annotvalues \texttt{array} \annotsemantics maps to OCaml's \texttt{array} type instead of \texttt{list}. \annotexample ## atdgen () ## type t = { id : int; data : string list ; } ## () ## \annotpar{Sum types} \annotposition after a sum type (denoted by square brackets) \annotvalues \texttt{classic} \annotsemantics maps to OCaml's classic variants instead of polymorphic variants. \annotexample ## atdgen () ## type fruit = [ Apple | Orange ] ## () ## translates to the following OCaml type definition: ## ocaml () ## type fruit = Apple | Orange ## () ## \annotpar{Shared values} \annotposition after a \texttt{shared} type \annotvalues \texttt{ref} \annotsemantics wraps the value using OCaml's \texttt{ref} type, which is as of Atdgen 1.1.0 the only way of sharing values other than records. \annotexample ## atdgen () ## type shared_string = string shared ## () ## translates to the following OCaml type definition: ## ocaml () ## type shared_string = string ref ## () ## ## annot_field "validator" ## \annotposition after any type expression except type variables \annotvalues OCaml function that takes one argument of the given type and returns a bool \annotsemantics \texttt{atdgen -v} produces for each type named \textit{t} a function \texttt{validate\_}\textit{t}: ## ocaml () ## val validate_t : t -> bool ## () ## Such a function returns true if and only if the value and all of its subnodes pass all the validators specified by annotations of the form \texttt{}. \annotexample ## atdgen () ## type positive = int type point = { x : positive; y : positive; z : int; } (* Some validating function from a user-defined module Point *) ## () ## The generated \texttt{validate\_point} function is equivalent to the following: ## ocaml () ## let validate_point p = Point.validate p && (fun x -> x > 0) p.x && (fun x -> x > 0) p.y ## () ## ## annot_section ~label:"ocaml-biniou" "ocaml\\_biniou" ## Section \texttt{ocaml\_biniou} takes precedence over section \texttt{ocaml} in Biniou mode (\texttt{-b}) for the following fields: \begin{itemize} \item \texttt{predef} (see \ref{ocaml.predef}) \item \texttt{module} (see \ref{ocaml.module}) \item \texttt{t} (see \ref{ocaml.t}) \end{itemize} ## annot_section ~label:"ocaml-json" "ocaml\\_json" ## Section \texttt{ocaml\_json} takes precedence over section \texttt{ocaml} in JSON mode (\texttt{-j}) for the following fields: \begin{itemize} \item \texttt{predef} (see \ref{ocaml.predef}) \item \texttt{module} (see \ref{ocaml.module}) \item \texttt{t} (see \ref{ocaml.t}) \end{itemize} \annotexample This example shows how to parse a field into a generic tree of type \texttt{Yojson.Safe.json} rather than a value of a specialized OCaml type. ## atdgen () ## type dyn = abstract type t = { foo: int; bar: dyn } ## () ## translates to the following OCaml type definitions: ## ocaml () ## type dyn = Yojson.Safe.json type t = { foo : int; bar : dyn } ## () ## Sample OCaml value of type \texttt{t}: ## ocaml () ## { foo = 12345; bar = `List [ `Int 12; `String "abc"; `Assoc [ "x", `Float 3.14; "y", `Float 0.0; "color", `List [ `Float 0.3; `Float 0.0; `Float 1.0 ] ] ] } ## () ## Corresponding JSON data as obtained with \texttt{string\_of\_t}: \begin{verbatim} {"foo":12345,"bar":[12,"abc",{"x":3.14,"y":0.0,"color":[0.3,0.0,1.0]}]} \end{verbatim} ## annot_section "doc" ## Unlike comments, \texttt{doc} annotations are meant to be propagated into the generated source code. This is useful for making generated interface files readable without having to consult the original ATD file. Generated source code comments can comply to a standard format and take advantage of documentation generators such as javadoc or ocamldoc. ## annot_field "text" ## \annotposition \begin{itemize} \item after the type name on the left-hand side of a type definition \item after the type expression on the right hand of a type definition (but not after any type expression) \item after record field names \item after variant names \end{itemize} \annotvalues UTF-8-encoded text using a minimalistic markup language \annotsemantics The markup language is defined as follows: \begin{itemize} \item Blank lines separate paragraphs. \item \verb!{{ }}! can be used to enclose inline verbatim text. \item \verb!{{{ }}}! can be used to enclose verbatim text where whitespace is preserved. \item The backslash character is used to escape special character sequences. In regular paragraph mode the special sequences are [\bs], [{{] and [{{{]. In inline verbatim text, special sequences are [\bs] and [}}]. In verbatim text, special sequences are [\bs] and [}}}]. \end{itemize} \annotexample The following is a full example demonstrating the use of \texttt{doc} annotations but also shows the full interface file \texttt{genealogy.mli} generated using: \begin{verbatim} $ atdgen -b genealogy.atd \end{verbatim} %$ Input file \texttt{genealogy.atd}: ## atdgen_biniou_mli ~prefix:"genealogy" "translates using \\texttt{atdgen -b genealogy.atd} into the following OCaml interface file \\texttt{genealogy\\_b.mli} with ocamldoc-compliant comments:" ## type tree = { members : person list; filiations : filiation list; } type filiation = { parent : person_id; child : person_id; filiation_type : filiation_type; } type filiation_type = { ?genetic : bool option; ?pregnancy : bool option; ?raised_from_birth : bool option; ?raised : bool option; ?stepchild : bool option; ?adopted : bool option; } type person_id = int type person = { person_id : person_id; name : string; ~gender : gender list; ?biological_gender : gender option; } type gender = [ | F | M ] ## () ## \section{Library} A library named \texttt{atdgen} is installed by the standard installation process. Only a fraction of it is officially supported and documented. The documentation is available online at \url{##= odoc_url ##}. atdgen-1.3.1/manual/atdgen-manual.mlx000066400000000000000000000155251226670520600175100ustar00rootroot00000000000000% -*- latex -*- ## #use "../ag_version.ml";; ## \documentclass[letterpaper,10pt]{article} \usepackage{ae} \usepackage{hyperref} \usepackage{hevea} \usepackage{verbatim} \usepackage{alltt} \usepackage[latin1]{inputenc} \usepackage[T1]{fontenc} \usepackage{url} \usepackage{booktabs} \title{Atdgen reference manual\\ release ##= version ##} \author{Martin Jambon\\ $\copyright$ 2010--2011 MyLife} %\date{October 19, 2072} \pagestyle{headings} % We suppress indentation at the beginning of each paragraph because paragraphs % are short and indentation is used heavily for bullet points and code examples \setlength{\parindent}{0mm} \setlength{\parskip}{2mm} % Thickness of top and bottom lines of tables (\toprule, \bottomrule) \setlength{\heavyrulewidth}{1.5pt} % Note: \toprule, \midrule and \bottomrule are really nice-looking but are not % understood by hevea. \usepackage{alltt} \usepackage{color} \newcommand\Clinenum[1]{#1} \definecolor{CconstructorColor}{rgb}{0.00,0.20,0.80} \newcommand\Cconstructor[1]{\textcolor{CconstructorColor}{#1}} \definecolor{CcommentColor}{rgb}{0.60,0.00,0.00} \newcommand\Ccomment[1]{\textcolor{CcommentColor}{#1}} \definecolor{CstringColor}{rgb}{0.67,0.27,0.27} \newcommand\Cstring[1]{\textcolor{CstringColor}{#1}} \newcommand\Cquotation[1]{#1} \definecolor{CalphakeywordColor}{rgb}{0.50,0.50,0.50} \newcommand\Calphakeyword[1]{\textcolor{CalphakeywordColor}{#1}} \newcommand\Cnonalphakeyword[1]{#1} \definecolor{CandColor}{rgb}{0.00,0.50,0.00} \newcommand\Cand[1]{\textcolor{CandColor}{#1}} \definecolor{CasColor}{rgb}{0.00,0.50,0.00} \newcommand\Cas[1]{\textcolor{CasColor}{#1}} \definecolor{CclassColor}{rgb}{0.00,0.50,0.00} \newcommand\Cclass[1]{\textcolor{CclassColor}{#1}} \definecolor{CconstraintColor}{rgb}{0.00,0.50,0.00} \newcommand\Cconstraint[1]{\textcolor{CconstraintColor}{#1}} \definecolor{CexceptionColor}{rgb}{0.00,0.50,0.00} \newcommand\Cexception[1]{\textcolor{CexceptionColor}{#1}} \definecolor{CexternalColor}{rgb}{0.00,0.50,0.00} \newcommand\Cexternal[1]{\textcolor{CexternalColor}{#1}} \definecolor{CfunColor}{rgb}{0.00,0.50,0.00} \newcommand\Cfun[1]{\textcolor{CfunColor}{#1}} \definecolor{CfunctionColor}{rgb}{0.00,0.50,0.00} \newcommand\Cfunction[1]{\textcolor{CfunctionColor}{#1}} \definecolor{CfunctorColor}{rgb}{0.00,0.50,0.00} \newcommand\Cfunctor[1]{\textcolor{CfunctorColor}{#1}} \definecolor{CinColor}{rgb}{0.00,0.50,0.00} \newcommand\Cin[1]{\textcolor{CinColor}{#1}} \definecolor{CinheritColor}{rgb}{0.00,0.50,0.00} \newcommand\Cinherit[1]{\textcolor{CinheritColor}{#1}} \definecolor{CinitializerColor}{rgb}{0.00,0.50,0.00} \newcommand\Cinitializer[1]{\textcolor{CinitializerColor}{#1}} \definecolor{CletColor}{rgb}{0.00,0.50,0.00} \newcommand\Clet[1]{\textcolor{CletColor}{#1}} \definecolor{CmethodColor}{rgb}{0.00,0.50,0.00} \newcommand\Cmethod[1]{\textcolor{CmethodColor}{#1}} %\definecolor{CmoduleColor}{rgb}{0.00,0.50,0.00} %\newcommand\Cmodule[1]{\textcolor{CmoduleColor}{#1}} \definecolor{CmutableColor}{rgb}{0.00,0.50,0.00} \newcommand\Cmutable[1]{\textcolor{CmutableColor}{#1}} \definecolor{CofColor}{rgb}{0.00,0.50,0.00} \newcommand\Cof[1]{\textcolor{CofColor}{#1}} \definecolor{CprivateColor}{rgb}{0.00,0.50,0.00} \newcommand\Cprivate[1]{\textcolor{CprivateColor}{#1}} \definecolor{CrecColor}{rgb}{0.00,0.50,0.00} \newcommand\Crec[1]{\textcolor{CrecColor}{#1}} \definecolor{CtypeColor}{rgb}{0.00,0.50,0.00} \newcommand\Ctype[1]{\textcolor{CtypeColor}{#1}} \definecolor{CvalColor}{rgb}{0.00,0.50,0.00} \newcommand\Cval[1]{\textcolor{CvalColor}{#1}} \definecolor{CvirtualColor}{rgb}{0.00,0.50,0.00} \newcommand\Cvirtual[1]{\textcolor{CvirtualColor}{#1}} \definecolor{CdoColor}{rgb}{0.47,0.67,0.67} \newcommand\Cdo[1]{\textcolor{CdoColor}{#1}} \definecolor{CdoneColor}{rgb}{0.47,0.67,0.67} \newcommand\Cdone[1]{\textcolor{CdoneColor}{#1}} \definecolor{CdowntoColor}{rgb}{0.47,0.67,0.67} \newcommand\Cdownto[1]{\textcolor{CdowntoColor}{#1}} \definecolor{CelseColor}{rgb}{0.47,0.67,0.67} \newcommand\Celse[1]{\textcolor{CelseColor}{#1}} \definecolor{CforColor}{rgb}{0.47,0.67,0.67} \newcommand\Cfor[1]{\textcolor{CforColor}{#1}} \definecolor{CifColor}{rgb}{0.47,0.67,0.67} \newcommand\Cif[1]{\textcolor{CifColor}{#1}} \definecolor{ClazyColor}{rgb}{0.47,0.67,0.67} \newcommand\Clazy[1]{\textcolor{ClazyColor}{#1}} \definecolor{CmatchColor}{rgb}{0.47,0.67,0.67} \newcommand\Cmatch[1]{\textcolor{CmatchColor}{#1}} \definecolor{CnewColor}{rgb}{0.47,0.67,0.67} \newcommand\Cnew[1]{\textcolor{CnewColor}{#1}} \definecolor{CorColor}{rgb}{0.47,0.67,0.67} \newcommand\Cor[1]{\textcolor{CorColor}{#1}} \definecolor{CthenColor}{rgb}{0.47,0.67,0.67} \newcommand\Cthen[1]{\textcolor{CthenColor}{#1}} \definecolor{CtoColor}{rgb}{0.47,0.67,0.67} \newcommand\Cto[1]{\textcolor{CtoColor}{#1}} \definecolor{CtryColor}{rgb}{0.47,0.67,0.67} \newcommand\Ctry[1]{\textcolor{CtryColor}{#1}} \definecolor{CwhenColor}{rgb}{0.47,0.67,0.67} \newcommand\Cwhen[1]{\textcolor{CwhenColor}{#1}} \definecolor{CwhileColor}{rgb}{0.47,0.67,0.67} \newcommand\Cwhile[1]{\textcolor{CwhileColor}{#1}} \definecolor{CwithColor}{rgb}{0.47,0.67,0.67} \newcommand\Cwith[1]{\textcolor{CwithColor}{#1}} \definecolor{CassertColor}{rgb}{0.80,0.60,0.00} \newcommand\Cassert[1]{\textcolor{CassertColor}{#1}} \definecolor{CincludeColor}{rgb}{0.80,0.60,0.00} \newcommand\Cinclude[1]{\textcolor{CincludeColor}{#1}} \definecolor{CopenColor}{rgb}{0.80,0.60,0.00} \newcommand\Copen[1]{\textcolor{CopenColor}{#1}} \definecolor{CbeginColor}{rgb}{0.60,0.00,0.60} \newcommand\Cbegin[1]{\textcolor{CbeginColor}{#1}} \definecolor{CendColor}{rgb}{0.60,0.00,0.60} \newcommand\Cend[1]{\textcolor{CendColor}{#1}} \definecolor{CobjectColor}{rgb}{0.60,0.00,0.60} \newcommand\Cobject[1]{\textcolor{CobjectColor}{#1}} \definecolor{CsigColor}{rgb}{0.60,0.00,0.60} \newcommand\Csig[1]{\textcolor{CsigColor}{#1}} \definecolor{CstructColor}{rgb}{0.60,0.00,0.60} \newcommand\Cstruct[1]{\textcolor{CstructColor}{#1}} \definecolor{CraiseColor}{rgb}{1.00,0.00,0.00} \newcommand\Craise[1]{\textcolor{CraiseColor}{#1}} \definecolor{CasrColor}{rgb}{0.50,0.50,0.50} \newcommand\Casr[1]{\textcolor{CasrColor}{#1}} \definecolor{ClandColor}{rgb}{0.50,0.50,0.50} \newcommand\Cland[1]{\textcolor{ClandColor}{#1}} \definecolor{ClorColor}{rgb}{0.50,0.50,0.50} \newcommand\Clor[1]{\textcolor{ClorColor}{#1}} \definecolor{ClslColor}{rgb}{0.50,0.50,0.50} \newcommand\Clsl[1]{\textcolor{ClslColor}{#1}} \definecolor{ClsrColor}{rgb}{0.50,0.50,0.50} \newcommand\Clsr[1]{\textcolor{ClsrColor}{#1}} \definecolor{ClxorColor}{rgb}{0.50,0.50,0.50} \newcommand\Clxor[1]{\textcolor{ClxorColor}{#1}} \definecolor{CmodColor}{rgb}{0.50,0.50,0.50} \newcommand\Cmod[1]{\textcolor{CmodColor}{#1}} \newcommand\Cfalse[1]{#1} \newcommand\Ctrue[1]{#1} \definecolor{CbarColor}{rgb}{0.47,0.67,0.67} \newcommand\Cbar[1]{\textcolor{CbarColor}{#1}} % Exception: \newcommand\Cmodule[1]{#1} \input{atd-annot.tex} \newcommand\bs{$\mathtt\backslash$} \begin{document} \maketitle \tableofcontents \include{atdgen-body} \end{document} atdgen-1.3.1/manual/hevea-insert1.html000066400000000000000000000002261226670520600176020ustar00rootroot00000000000000 atdgen-1.3.1/manual/hevea-insert2.html000066400000000000000000000000201226670520600175730ustar00rootroot00000000000000
atdgen-1.3.1/manual/hevea-insert3.html000066400000000000000000000000071226670520600176010ustar00rootroot00000000000000
atdgen-1.3.1/manual/macros.ml000066400000000000000000000105171226670520600160630ustar00rootroot00000000000000open Printf let latex_of_string s = let tokens = Caml2html.Input.string s in let buf = Buffer.create 1000 in Caml2html.Output_latex.ocaml buf tokens; Buffer.contents buf let print_ocaml s = print "\\begin{alltt}"; print (latex_of_string s); print "\\end{alltt}" (* Validate ATD syntax before printing *) let print_atd s = try ignore (Atd_util.load_string ~expand:true ~keep_poly:true ~inherit_fields:true ~inherit_variants:true s); print_ocaml s with e -> let msg = match e with Failure s | Atd_ast.Atd_error s -> s | _ -> Printexc.to_string e in Printf.eprintf "\ *** Invalid ATD *** %s *** Error *** %s %!" s msg; raise e let read_command_output f s = let ic = Unix.open_process_in s in (try while true do f (input_char ic) done with End_of_file -> ()); match Unix.close_process_in ic with Unix.WEXITED 0 -> () | _ -> invalid_arg ("read_command_output: " ^ s) let file_contents fn = let buf = Buffer.create 1000 in let ic = open_in fn in (try while true do bprintf buf "%s\n" (input_line ic) done with End_of_file -> () ); close_in ic; Buffer.contents buf let shell s = let buf = Buffer.create 100 in read_command_output (Buffer.add_char buf) s; print "\\begin{verbatim}"; print (Buffer.contents buf); (* no escaping! *) print "\\end{verbatim}" let suffix_of_output_type = function `Types -> "_t" | `Biniou -> "_b" | `Json -> "_j" | `Validators -> "_v" let check_atdgen ?prefix output_type s = let fn = match prefix with None -> Filename.temp_file "atdgen_" ".atd" | Some s -> s ^ ".atd" in let prefix = Filename.chop_extension fn in let suffix = suffix_of_output_type output_type in let mli = prefix ^ suffix ^ ".mli" in let ml = prefix ^ suffix ^ ".ml" in let oc = open_out fn in let finally () = close_out_noerr oc; Sys.remove fn; (try Sys.remove mli with _ -> ()); (try Sys.remove ml with _ -> ()); in try output_string oc s; close_out oc; let cmd = sprintf "../atdgen %s %s" (match output_type with `Types -> "-t" | `Biniou -> "-b" | `Json -> "-j" | `Validators -> "-v") fn in match Sys.command cmd with 0 -> let mli_data = file_contents mli in let ml_data = file_contents ml in finally (); mli_data, ml_data | n -> eprintf "\ -- File %s -- %s ---- Command failed: %s " fn s cmd; finally (); exit 1 with e -> finally (); raise e let print_atdgen ot s = ignore (check_atdgen ot s); print_atd s let ocaml () = Camlmix.print_with print_ocaml let atd () = Camlmix.print_with print_atd let atdgen_biniou () = Camlmix.print_with (print_atdgen `Biniou) let atdgen_json () = Camlmix.print_with (print_atdgen `Json) let atdgen = atdgen_biniou let print_atdgen_mli ?prefix ot msg s = let mli, ml = check_atdgen ?prefix ot s in print_atd s; print msg; print_ocaml mli let print_atdgen_ml ?prefix ot msg s = let mli, ml = check_atdgen ?prefix ot s in print_atd s; print msg; print_ocaml ml let atdgen_types_mli ?prefix msg = Camlmix.print_with (print_atdgen_mli ?prefix `Types msg) let atdgen_biniou_mli ?prefix msg = Camlmix.print_with (print_atdgen_mli ?prefix `Biniou msg) let atdgen_json_mli ?prefix msg = Camlmix.print_with (print_atdgen_mli ?prefix `Json msg) let atdgen_validate_mli ?prefix msg = Camlmix.print_with (print_atdgen_mli ?prefix `Validators msg) let atdgen_validate_ml ?prefix msg = Camlmix.print_with (print_atdgen_ml ?prefix `Validators msg) let current_annot_section = ref "" let current_annot_field = ref "" let annot_section ?label s = current_annot_section := s; let label = match label with None -> s | Some s -> s in print (sprintf "\\subsection{Section \\texttt{%s}\\label{%s}}" s label) let annot_field ?label field = current_annot_field := field; let s = !current_annot_section ^ "." ^ field in let label = match label with None -> s | Some s -> s in print (sprintf "\\subsubsection{Field \\texttt{%s}\\label{%s}}" s label) let odoc_url = "http://oss.wink.com/atdgen/atdgen-" ^ version ^ "/odoc/index.html" atdgen-1.3.1/test.atd000066400000000000000000000112631226670520600144400ustar00rootroot00000000000000 type def = abstract type r = { a : int ; b : bool; c : p; } type p = [ A | B of r | C ] 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 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 ; } atdgen-1.3.1/test2.atd000066400000000000000000000004051226670520600145160ustar00rootroot00000000000000type ('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.3.1/test3b.atd000066400000000000000000000004721226670520600146650ustar00rootroot00000000000000(* Biniou support only *) type a = string shared list type b = string shared type node_data = { value : string; neighbors : node list } type node = node_data shared type graph = node list type ref = int shared atdgen-1.3.1/test3j.atd000066400000000000000000000003651226670520600146760ustar00rootroot00000000000000(* JSON support only *) type json = abstract type dyn = abstract type t = { foo: int; bar: json; baz: dyn } type unixtime_list = int list atdgen-1.3.1/test4.atd000066400000000000000000000003201226670520600145140ustar00rootroot00000000000000 type 'x abs1 = abstract type 'x abs2 = abstract type 'x abs3 = abstract atdgen-1.3.1/test5.atd000066400000000000000000000010211226670520600145140ustar00rootroot00000000000000(* 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.3.1/test_atdgen_main.ml000066400000000000000000000313351226670520600166300ustar00rootroot00000000000000open 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 = { int1 : bool } type internals2 = { mutable int2 : bool } let test_ocaml_internals () = section "ocaml internals"; let f () = { int1 = Obj.magic false } in check (f () != f ()); let g () = { int1 = false } in check (g () == g ()); let h () = { int2 = false } in check (h () != h ()) 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.map2 (fun x x' -> 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.unixtime_list_of_string Test3j.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.foo = 12345; bar = `List [ `Int 12; `String "abc" ]; baz = `Bool false } in let s = Test3j.string_of_t x in let x' = Test3j.t_of_string s in check (x = x') let test_biniou_sharing_graph () = section "biniou sharing - graph"; let a = { Test3b.value = "a"; neighbors = [] } in let b = { Test3b.value = "b"; neighbors = [] } in a.Test3b.neighbors <- [ a; b ]; b.Test3b.neighbors <- [ b; a ]; let g = [ a; b ] in let s = Test3b.string_of_graph g in let g' = Test3b.graph_of_string s in check (g != g'); let a', b' = match g' with [ a'; b' ] -> a', b' | _ -> fail () in let a'', b'' = match a'.Test3b.neighbors with [ a''; b'' ] -> a'', b'' | _ -> fail () in check (a' == a''); check (b' == b'') let test_biniou_sharing_strings () = section "biniou sharing - strings"; let x = ref "abc" in let a = [| x; x |] in let b = x in let a' = Test3b.a_of_string (Test3b.string_of_a a) in let b' = Test3b.b_of_string (Test3b.string_of_b b) in check (a.(0) == b); check (a.(0) == a.(1)); check (a'.(0) != a.(0)); check (a'.(0) == a'.(1)); check (a'.(0) != b') 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_biniou_sharing_graph; test_biniou_sharing_strings; 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.3.1/test_lib.ml000066400000000000000000000017251226670520600151300ustar00rootroot00000000000000type 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