pax_global_header00006660000000000000000000000064122667052310014516gustar00rootroot0000000000000052 comment=13a4563faf1307e68750126336fa8f20083a30aa atd-1.1.1/000077500000000000000000000000001226670523100122665ustar00rootroot00000000000000atd-1.1.1/.gitignore000066400000000000000000000002461226670523100142600ustar00rootroot00000000000000*~ *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o *.annot *.run *.opt *.exe META VERSION atd_doc_lexer.ml atd_lexer.ml atd_parser.ml atd_parser.mli atd_version.ml atdcat dep atd-1.1.1/INSTALL000066400000000000000000000014211226670523100133150ustar00rootroot00000000000000 Installation instructions for atd Requirements: - Objective Caml (>= 3.11 is fine, earlier versions are probably fine too) - GNU make - Findlib (`ocamlfind' command) - menhir http://pauillac.inria.fr/~fpottier/menhir/ - easy-format http://martin.jambon.free.fr/easy-format.html GODI makes the installation process straightforward, although other package managers can be equally convenient. Manual installation is done using: 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. Uninstallation: make uninstall Bugs and feedback should be sent to Martin Jambon or . atd-1.1.1/LICENSE000066400000000000000000000025511226670523100132760ustar00rootroot00000000000000Copyright (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. atd-1.1.1/META.in000066400000000000000000000001741226670523100133460ustar00rootroot00000000000000description = "Adjustable Type Definitions" requires = "easy-format" archive(byte) = "atd.cma" archive(native) = "atd.cmxa" atd-1.1.1/Makefile000066400000000000000000000104641226670523100137330ustar00rootroot00000000000000VERSION = 1.1.1 ifeq "$(shell ocamlc -config |grep os_type)" "os_type: Win32" EXE=.exe else EXE= endif SOURCES = \ atd_version.ml \ atd_ast.mli atd_ast.ml \ atd_annot.mli atd_annot.ml \ atd_parser.mli atd_parser.mly \ atd_lexer.mll \ atd_doc_lexer.mll atd_doc.mli atd_doc.ml \ atd_print.mli atd_print.ml \ atd_predef.ml \ atd_check.ml \ atd_expand.mli atd_expand.ml \ atd_inherit.mli atd_inherit.ml \ atd_tsort.mli atd_tsort.ml \ atd_util.mli atd_util.ml \ atd_reflect.mli atd_reflect.ml \ atd_indent.mli atd_indent.ml MLY = $(filter %.mly, $(SOURCES)) MLL = $(filter %.mll, $(SOURCES)) 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)) INSTALL_EXTRAS = atd_check.ml atd_doc_lexer.mll atd_doc_lexer.ml \ atd_lexer.mll atd_lexer.ml atd_predef.ml atd_version.ml OCAMLFLAGS = -dtypes -g OCAMLPACKS = easy-format unix str DOCFILES = \ atd_ast \ atd_annot \ atd_doc \ atd_print \ atd_expand \ atd_inherit \ atd_util \ atd_reflect \ atd_indent DOCSOURCES = $(addsuffix .mli, $(DOCFILES)) ifndef PREFIX PREFIX = $(shell dirname $$(dirname $$(which ocamlfind))) export PREFIX endif ifndef BINDIR BINDIR = $(PREFIX)/bin export BINDIR endif .PHONY: default all opt install uninstall reinstall default: all opt all: VERSION META atd.cma opt: VERSION META atd.cmxa atdcat$(EXE) install: META test ! -f atdcat || cp atdcat $(BINDIR)/ test ! -f atdcat.exe || cp atdcat.exe $(BINDIR)/ ocamlfind install atd META \ $(MLI) $(CMI) $(CMO) $(CMX) $(O) atd.cma atd.a atd.cmxa \ $(INSTALL_EXTRAS) uninstall: test ! -f $(BINDIR)/atdcat || rm $(BINDIR)/atdcat test ! -f $(BINDIR)/atdcat.exe || rm $(BINDIR)/atdcat.exe ocamlfind remove atd reinstall: $(MAKE) uninstall || : $(MAKE) install atd_version.ml: Makefile echo 'let version = "$(VERSION)"' > atd_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)" $< atd_parser.mli: atd_parser.mly menhir $< atd_parser.ml: atd_parser.mly menhir $< atd_lexer.ml: atd_lexer.mll ocamllex $< atd_doc_lexer.ml: atd_doc_lexer.mll ocamllex $< dep: $(SOURCES) Makefile ocamlfind ocamldep -package "$(OCAMLPACKS)" $(MLI) $(ML) > dep ifneq ($(MAKECMDGOALS),clean) -include dep endif atd.cma: dep $(CMI) $(CMO) ocamlfind ocamlc $(OCAMLFLAGS) -o atd.cma -a $(CMO) atd.cmxa: dep $(CMI) $(CMX) ocamlfind ocamlopt $(OCAMLFLAGS) -o atd.cmxa -a $(CMX) atdcat$(EXE): dep $(CMI) $(CMX) atdcat.ml ocamlfind ocamlopt $(OCAMLFLAGS) -o atdcat$(EXE) \ -package "$(OCAMLPACKS)" -linkpkg \ $(CMX) atdcat.ml .PHONY: doc doc: odoc/index.html atdcat$(EXE) cd manual; $(MAKE) odoc/index.html: $(CMI) mkdir -p odoc ocamlfind ocamldoc -d odoc -html \ -t 'ATD library documentation' \ -package "$(OCAMLPACKS)" $(DOCSOURCES) .PHONY: test test: atdcat$(EXE) test.atd test2.atd ./atdcat test.atd > test.out ./atdcat test.out > test.out.out cmp test.out test.out.out ./atdcat -x test2.atd > test2.out .PHONY: docdemo docdemo: atdcat$(EXE) test.atd ./atdcat test.atd -html-doc -strip ocaml > test-out.atd caml2html -ext html:cat test-out.atd -nf sed -i -e 's!!\ div.atd-doc { \ border-left: solid #ccc 6px; \ margin-bottom: 50px; \ margin-left: 30px; \ padding: 5px; \ } \ div.atd-doc p { \ margin: 0px; \ padding: 0px; \ } \ div.atd-doc pre { \ margin-left: 40px; \ margin-right: 0px; \ margin-top: 10px; \ margin-bottom: 10px; \ } \ !' test-out.atd.html .PHONY: clean clean: rm -f dep rm -f atd_version.ml rm -f $(CMI) $(CMO) $(CMX) $(O) *.annot *.cma *.cmxa *.a rm -f $(patsubst %.mly,%.mli, $(MLY)) rm -f $(patsubst %.mly,%.ml, $(MLY)) rm -f $(patsubst %.mll,%.ml, $(MLL)) rm -f atdcat.cm[ioxa] atdcat.o atdcat.cma atdcat.cmxa atdcat$(EXE) rm -rf odoc cd manual; $(MAKE) clean .PHONY: release release: ./release.sh atd-1.1.1/README.md000066400000000000000000000006731226670523100135530ustar00rootroot00000000000000ATD stands for Adaptable Type Definitions. It is a syntax for defining cross-language data types and it is used by [atdgen](https://github.com/mjambon/atdgen) for defining the type of [JSON](http://json.org) data and generating efficient serializers, deserializers and validators. The ATD language and its OCaml library were designed and implemented at MyLife by Martin Jambon. We distribute the source code under the terms of a BSD license. atd-1.1.1/atd_annot.ml000066400000000000000000000062331226670523100145730ustar00rootroot00000000000000 open Printf type t = Atd_ast.annot let error_at loc s = failwith (sprintf "%s:\n%s" (Atd_ast.string_of_loc loc) s) let has_section k l = try ignore (List.assoc k l); true with Not_found -> false let has_field k k2 l = List.exists ( fun k1 -> try (* each section must be unique *) let _, l2 = List.assoc k1 l in ignore (List.assoc k2 l2); true with Not_found -> false ) k let rec find f = function [] -> None | x :: l -> match f x with None -> find f l | Some _ as y -> y let get_flag k k2 l = let result = find ( fun k1 -> try (* each section must be unique *) let loc, l2 = List.assoc k1 l in let loc, o = List.assoc k2 l2 in match o with None -> Some true | Some "true" -> Some true | Some "false" -> Some false | Some s -> error_at loc (sprintf "Invalid value %S for flag %s.%s" s k1 k2) with Not_found -> None ) k in match result with None -> false | Some x -> x let get_field parse default k k2 l = let result = find ( fun k1 -> try (* each section must be unique *) let loc, l2 = List.assoc k1 l in let loc, o = List.assoc k2 l2 in match o with Some s -> (match parse s with Some x as y -> y | None -> error_at loc (sprintf "Invalid annotation <%s %s=%S>" k1 k2 s) ) | None -> error_at loc (sprintf "Missing value for annotation %s.%s" k1 k2) with Not_found -> None ) k in match result with None -> default | Some x -> x (* replace first occurrence, if any *) let rec replace k v = function (k', _) as x :: l -> if k = k' then (k, v) :: l else x :: replace k v l | [] -> [] let set_field loc k k2 v l : Atd_ast.annot = try let section_loc, section = List.assoc k l in let section = try let _field = List.assoc k2 section in replace k2 (loc, v) section with Not_found -> (k2, (loc, v)) :: section in replace k (section_loc, section) l with Not_found -> (k, (loc, [ k2, (loc, v) ])) :: l let collapse merge l = let tbl = Hashtbl.create 10 in let n = ref 0 in List.iter ( fun (s1, f1) -> incr n; try let _, f2 = Hashtbl.find tbl s1 in Hashtbl.replace tbl s1 (!n, merge f1 f2) with Not_found -> Hashtbl.add tbl s1 (!n, f1) ) (List.rev l); let l = Hashtbl.fold (fun s (i, f) l -> (i, (s, f)) :: l) tbl [] in let l = List.sort (fun (i, _) (j, _) -> compare j i) l in List.map snd l let override_values x1 x2 = x1 let override_fields (loc1, l1) (loc2, l2) = (loc1, collapse override_values (l1 @ l2)) let merge l = collapse override_fields l let create_id = let n = ref (-1) in fun () -> incr n; if !n < 0 then failwith "Atd_annot.create_id: counter overflow" else string_of_int !n atd-1.1.1/atd_annot.mli000066400000000000000000000070331226670523100147430ustar00rootroot00000000000000 (** Utilities for interpreting annotations of type {!Atd_ast.annot} *) type t = Atd_ast.annot (** Sample annotation in ATD syntax with legend: {v section a section b ----------- ------ | | | | | | | +- field without a value | | | | | +- field value | | | +- field name | +- section name v} The following rules must be followed for a proper use of this module: - There may not be two sections with the same name. The [merge] function can be used to merge sections. - Section order doesn't matter as long as section names are unique. - Field names within a section should be unique. If not, only the first occurrence of each field is meaningful. - Field values may be arbitrary strings. *) val has_section : string -> t -> bool (** Return true if such a section (first-level key) exists. *) val has_field : string list -> string -> t -> bool (** [has_field section_names field_name annotations] returns true if at least one section exists with a name in [section_names] and one of its fields named [field_name]. Each section should be unique. *) val get_flag : string list -> string -> t -> bool (** [get_flag section_names field_name] looks sequentially into the sections specified by [section_names] for a field named [field_name]. If no such field can be found in any section, the result is [false]. Otherwise, the search stops with the first field matching one of the section names and the field name. If the field has no associated value, the result is [true]. If the field value is ["true"] then [true] is returned. Likewise, if the field value is ["false"] then [false] is returned. If the field value is anything else, a [Failure] exception is raised. Each section should be unique. Given the following annotations in the ATD syntax noted [a]: {v v} We obtain the following results: {v # get_flag \["ocaml_312"; "ocaml"\] "openin" a;; \- : true # get_flag \["ocaml_311"; "ocaml"\] "openin" a;; \- : false # get_flag \["ocaml_312"\] "openin" a;; \- : true # get_flag \["ocaml_311"\] "openin" a;; \- : false # get_flag \["ocaml"\] "openin" a;; \- : false v} *) val get_field : (string -> 'a option) -> 'a -> string list -> string -> t -> 'a (** [get_field parse default section_names field_name annotations] looks sequentially into the sections specified by [section_names] for a field named [field_name]. If no such field exists, the [default] value is returned. If the field is present, the associated value is parsed using the given function [parse] which should return [None] in order to indicate an invalid value. If the field is present without an associated value or if [parse] returns [None], a [Failure] exception is raised. Each section should be unique. *) val set_field : Atd_ast.loc -> string -> string -> string option -> t -> t (** [set_field loc section_name field_name value annotations] sets a field, reusing existing section [section_name] if it exists, preserving the position of field [field_name] and overwriting its value if it exists. *) val merge : t -> t (** Merge sections of the same name together, and keeps only the first occurrence of each field. {v v} becomes {v v} *) val create_id : unit -> string (** Create a unique numeric ID *) atd-1.1.1/atd_ast.ml000066400000000000000000000151741226670523100142470ustar00rootroot00000000000000open Lexing type loc = Lexing.position * Lexing.position let dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos) exception Atd_error of string type full_module = module_head * module_body and module_head = loc * annot and module_body = module_item list and annot = annot_section list and annot_section = string * (loc * annot_field list) and annot_field = string * (loc * string option) and type_def = loc * (string * type_param * annot) * type_expr and module_item = [ `Type of type_def ] and type_param = string list and type_expr = [ `Sum of (loc * variant list * annot) | `Record of (loc * field list * annot) | `Tuple of (loc * cell list * annot) | `List of (loc * type_expr * annot) | `Option of (loc * type_expr * annot) | `Nullable of (loc * type_expr * annot) | `Shared of (loc * type_expr * annot) | `Wrap of (loc * type_expr * annot) | `Name of (loc * type_inst * annot) | `Tvar of (loc * string) ] (* `List, `Option, `Nullable, `Shared and `Wrap are the only predefined types with a type parameter (and no special syntax). *) and type_inst = loc * string * type_expr list and variant = [ `Variant of (loc * (string * annot) * type_expr option) | `Inherit of (loc * type_expr) ] and cell = loc * type_expr * annot and field_kind = [ `Required | `Optional | `With_default ] and field = [ `Field of (loc * (string * field_kind * annot) * type_expr) | `Inherit of (loc * type_expr) ] let loc_of_type_expr = function `Sum (loc, _, _) | `Record (loc, _, _) | `Tuple (loc, _, _) | `List (loc, _, _) | `Option (loc, _, _) | `Nullable (loc, _, _) | `Shared (loc, _, _) | `Wrap (loc, _, _) | `Name (loc, _, _) | `Tvar (loc, _) -> loc let set_type_expr_loc loc = function `Sum (_, a, b) -> `Sum (loc, a, b) | `Record (_, a, b) -> `Record (loc, a, b) | `Tuple (_, a, b) -> `Tuple (loc, a, b) | `List (_, a, b) -> `List (loc, a, b) | `Option (_, a, b) -> `Option (loc, a, b) | `Nullable (_, a, b) -> `Nullable (loc, a, b) | `Shared (_, a, b) -> `Shared (loc, a, b) | `Wrap (_, a, b) -> `Wrap (loc, a, b) | `Name (_, a, b) -> `Name (loc, a, b) | `Tvar (_, a) -> `Tvar (loc, a) let string_of_loc (pos1, pos2) = let line1 = pos1.pos_lnum and start1 = pos1.pos_bol in Printf.sprintf "File %S, line %i, characters %i-%i" pos1.pos_fname line1 (pos1.pos_cnum - start1) (pos2.pos_cnum - start1) let error s = raise (Atd_error s) let error_at loc s = error (string_of_loc loc ^ "\n" ^ s) let annot_of_type_expr = function `Sum (_, _, an) | `Record (_, _, an) | `Tuple (_, _, an) | `List (_, _, an) | `Option (_, _, an) | `Nullable (_, _, an) | `Shared (_, _, an) | `Wrap (_, _, an) | `Name (_, _, an) -> an | `Tvar (_, _) -> [] let map_annot f = function `Sum (loc, vl, a) -> `Sum (loc, vl, f a) | `Record (loc, fl, a) -> `Record (loc, fl, f a) | `Tuple (loc, tl, a) -> `Tuple (loc, tl, f a) | `List (loc, t, a) -> `List (loc, t, f a) | `Option (loc, t, a) -> `Option (loc, t, f a) | `Nullable (loc, t, a) -> `Nullable (loc, t, f a) | `Shared (loc, t, a) -> `Shared (loc, t, f a) | `Wrap (loc, t, a) -> `Wrap (loc, t, f a) | `Tvar _ as x -> x | `Name (loc, (loc2, name, args), a) -> `Name (loc, (loc2, name, args), f a) let rec amap_type_expr f (x : type_expr) = match x with `Sum (loc, vl, a) -> `Sum (loc, List.map (amap_variant f) vl, f a) | `Record (loc, fl, a) -> `Record (loc, List.map (amap_field f) fl, f a) | `Tuple (loc, tl, a) -> `Tuple (loc, List.map (amap_cell f) tl, f a) | `List (loc, t, a) -> `List (loc, amap_type_expr f t, f a) | `Option (loc, t, a) -> `Option (loc, amap_type_expr f t, f a) | `Nullable (loc, t, a) -> `Nullable (loc, amap_type_expr f t, f a) | `Shared (loc, t, a) -> `Shared (loc, amap_type_expr f t, f a) | `Wrap (loc, t, a) -> `Wrap (loc, amap_type_expr f t, f a) | `Tvar _ as x -> x | `Name (loc, (loc2, name, args), a) -> `Name (loc, (loc2, name, List.map (amap_type_expr f) args), f a) and amap_variant f = function `Variant (loc, (name, a), o) -> let o = match o with None -> None | Some x -> Some (amap_type_expr f x) in `Variant (loc, (name, f a), o) | `Inherit (loc, x) -> `Inherit (loc, amap_type_expr f x) and amap_field f = function `Field (loc, (name, kind, a), x) -> `Field (loc, (name, kind, f a), amap_type_expr f x) | `Inherit (loc, x) -> `Inherit (loc, amap_type_expr f x) and amap_cell f (loc, x, a) = (loc, amap_type_expr f x, f a) let amap_module_item f (`Type (loc, (name, param, a), x)) = `Type (loc, (name, param, f a), amap_type_expr f x) let amap_head f (loc, a) = (loc, f a) let amap_body f l = List.map (amap_module_item f) l let map_all_annot f ((head, body) : full_module) = (amap_head f head, amap_body f body) let rec fold (f : type_expr -> 'a -> 'a) (x : type_expr) acc = let acc = f x acc in match x with `Sum (loc, variant_list, annot) -> List.fold_right (fold_variant f) variant_list acc | `Record (loc, field_list, annot) -> List.fold_right (fold_field f) field_list acc | `Tuple (loc, l, annot) -> List.fold_right (fun (loc, x, _) acc -> fold f x acc) l acc | `List (loc, type_expr, annot) -> fold f type_expr acc | `Option (loc, type_expr, annot) -> fold f type_expr acc | `Nullable (loc, type_expr, annot) -> fold f type_expr acc | `Shared (loc, type_expr, annot) -> fold f type_expr acc | `Wrap (loc, type_expr, annot) -> fold f type_expr acc | `Name (loc, (loc2, name, type_expr_list), annot) -> List.fold_right (fold f) type_expr_list acc | `Tvar (loc, string) -> acc and fold_variant f x acc = match x with `Variant (loc, _, Some type_expr) -> fold f type_expr acc | `Variant _ -> acc | `Inherit (loc, type_expr) -> fold f type_expr acc and fold_field f x acc = match x with `Field (loc, _, type_expr) -> fold f type_expr acc | `Inherit (loc, type_expr) -> fold f type_expr acc module Type_names = Set.Make (String) let union l = List.fold_left Type_names.union Type_names.empty l let extract_type_names ?(ignorable = []) x = let ign s = List.mem s ignorable in let add s set = if ign s then set else Type_names.add s set in let acc = fold ( fun x acc -> match x with `Name (loc, (loc2, name, l), a) -> add name acc | _ -> acc ) x Type_names.empty in Type_names.elements acc let is_parametrized x = fold (fun x b -> b || match x with `Tvar _ -> true | _ -> false) x false atd-1.1.1/atd_ast.mli000066400000000000000000000173201226670523100144130ustar00rootroot00000000000000 (** Abstract syntax tree (AST) representing ATD data *) type loc = Lexing.position * Lexing.position (** A location in the source code. *) exception Atd_error of string (** Exception raised by functions of the [atd] library and indicating errors. *) type annot = annot_section list (** An annotation, consisting of a sequence of sections. {!Atd_annot} provides utilities for handling annotations. *) and annot_section = string * (loc * annot_field list) (** represents a single annotation within edgy brackets. [<"foo" bar baz="123">] in ATD syntax translates to: {v ("foo", (loc1, [ ("bar", (loc2, None)); ("baz", (loc3, Some "123")) ] )) v} *) and annot_field = string * (loc * string option) (** An annotation field, i.e. a key with an optional value within an annotation. *) type full_module = module_head * module_body (** Contents of an ATD file. *) and module_head = loc * annot (** The head of an ATD file is just a list of annotations. *) and module_body = module_item list (** The body of an ATD file is a list of type definitions. Type definitions are implicitely mutually recursive. They can be sorted based on dependencies using {!Atd_util.tsort}. *) and module_item = [ `Type of type_def ] (** There is currently only one kind of module items, that is single type definitions. *) and type_def = loc * (string * type_param * annot) * type_expr (** A type definition. *) and type_param = string list (** List of type variables without the tick. *) and type_expr = [ `Sum of (loc * variant list * annot) | `Record of (loc * field list * annot) | `Tuple of (loc * cell list * annot) | `List of (loc * type_expr * annot) | `Option of (loc * type_expr * annot) | `Nullable of (loc * type_expr * annot) | `Shared of (loc * type_expr * annot) | `Wrap of (loc * type_expr * annot) | `Name of (loc * type_inst * annot) | `Tvar of (loc * string) ] (** A type expression is one of the following: - [`Sum]: a sum type (within square brackets) - [`Record]: a record type (within curly braces) - [`Tuple]: a tuple (within parentheses) - [`List]: a list type written [list] with its parameter e.g. [int list] - [`Option]: an option type written [option] with its parameter e.g. [string option] - [`Nullable]: adds a null value to a type. [`Option] should be preferred over [`Nullable] since it makes it possible to distinguish [Some None] from [None]. - [`Shared]: values for which sharing must be preserved. Such type expressions may not be parametrized. Values may only be shared if the source location of the type expression is the same. - [`Wrap]: optional wrapping of a type. For example, a timestamp represented as a string can be wrapped within a proper time type. In that case, the wrapper would parse the timestamp and convert it into the internal representation of its choice. Unwrapping would consist in converting it back to a string. - [`Name]: a type name other than [list] or [option], including the predefined types [unit], [bool], [int], [float], [string] and [abstract]. - [`Tvar]: a type variable identifier without the tick *) and type_inst = loc * string * type_expr list (** A type name and its arguments *) and variant = [ `Variant of (loc * (string * annot) * type_expr option) | `Inherit of (loc * type_expr) ] (** A single variant or an [inherit] statement. [`Inherit] statements can be expanded into variants using {!Atd_inherit} or at loading time using the [inherit_variant] option offered by the {!Atd_util} functions. *) and cell = loc * type_expr * annot (** Tuple cell. Note that annotations placed before the type expression are supported and represented here, such as the third cell in [(float * float * float)]. *) and field_kind = [ `Required | `Optional | `With_default ] (** Different kinds of record fields based on the - [`Required]: required field, e.g. [id : string] - [`Optional]: optional field without a default value, e.g. [?name : string option]. The ATD type of the field value must be an option type. - [`With_default]: optional field with a default value, e.g. [~websites : string list]. The default value may be implicit or specified explicitely using annotations. Each target language that cannot omit fields may have to specify the default in its own syntax. Sample ATD file: {v type level = [ Beginner | Advanced | Expert ] type user = \{ id : string; ?name : string option; (* Field may be omitted when no value is set, if permitted by the target language. *) ~websites : string list; (* Implicit default: empty list. Field may be omitted if the field value is equal to the default value and the target language permits it. *) ~level : level; (* Explicit default for `ocaml'. For instance there is no `json' annotation because the default for undefined `JSON' fields would be to omit them. *) } v} *) and field = [ `Field of (loc * (string * field_kind * annot) * type_expr) | `Inherit of (loc * type_expr) ] (** A single record field or an [inherit] statement. [`Inherit] statements can be expanded into fields using {!Atd_inherit} or at loading time using the [inherit_fields] option offered by the {!Atd_util} functions. *) val loc_of_type_expr : type_expr -> loc (** Extract the source location of any type expression. *) val set_type_expr_loc : loc -> type_expr -> type_expr (** Replace the location of the given expression. This is a shallow substitution. Sub-expressions are not affected. *) val string_of_loc : loc -> string (** Convert a location into a human-readable string such as [File "foo.atd", line 123, characters 40-45]. *) val error : string -> 'a (** [error s] is a shorthand for [raise (Atd_error s)]. *) val error_at : loc -> string -> 'a (** [error_at loc s] raises [Atd_error s'] where [s'] is the location followed by [s]. *) val dummy_loc : loc (** Dummy value for predefined constructs that are not associated with a useful source location. Should not show up in error messages. *) val annot_of_type_expr : type_expr -> annot (** Return the annotations associated with a type expression. Note that there can be annotations in a variety of places, not just after type expressions. *) val map_annot : (annot -> annot) -> type_expr -> type_expr (** Replacement of the annotations associated with a type expression. This is a shallow transformation. Sub-expressions are not affected. *) val map_all_annot : (annot -> annot) -> full_module -> full_module (** Replacement of all annotations occurring in an ATD module. *) val fold : (type_expr -> 'a -> 'a) -> type_expr -> 'a -> 'a (** Iteration and accumulation over each [type_expr] node within a given [type_expr]. *) val extract_type_names : ?ignorable : string list -> type_expr -> string list (** Extract all the type names occurring in a type expression under [`Name], without duplicates. @param ignorable specifies a list of type names to exclude from the result *) val is_parametrized : type_expr -> bool (** Test whether a type expression contains type variables ([`Tvar]). *) atd-1.1.1/atd_check.ml000066400000000000000000000113321226670523100145250ustar00rootroot00000000000000(* Semantic verification *) open Printf open Atd_ast let add_name accu = function `Name (_, (loc, k, tal), _) -> k :: accu | _ -> accu let get_kind = function `Sum _ -> `Sum | `Record _ -> `Record | _ -> `Other let check_inheritance tbl (t0 : type_expr) = let not_a kind x = let msg = sprintf "Cannot inherit from non-%s type" (match kind with `Sum -> "variant" | `Record -> "record" | _ -> assert false) in error_at (loc_of_type_expr t0) msg in let rec check kind inherited (t : type_expr) = match t with `Sum (_, vl, _) when kind = `Sum -> List.iter ( function `Inherit (_, t) -> check kind inherited t | `Variant _ -> () ) vl | `Record (_, fl, _) when kind = `Record -> List.iter ( function `Inherit (_, t) -> check kind inherited t | `Field _ -> () ) fl | `Sum _ | `Record _ | `Tuple _ | `List _ | `Option _ | `Nullable _ | `Shared _ | `Wrap _ as x -> not_a kind x | `Name (_, (loc, k, tal), _) -> if List.mem k inherited then error_at (loc_of_type_expr t0) "Cyclic inheritance" else let (arity, opt_def) = try Hashtbl.find tbl k with Not_found -> error_at loc ("Undefined type " ^ k) in (match opt_def with None -> () | Some (_, _, t) -> check kind (k :: inherited) t ) | `Tvar _ -> error_at (loc_of_type_expr t0) "Cannot inherit from a type variable" in check (get_kind t0) (add_name [] t0) t0 let check_type_expr tbl tvars (t : type_expr) = let rec check : type_expr -> unit = function `Sum (_, vl, _) as x -> List.iter (check_variant (Hashtbl.create 10)) vl; check_inheritance tbl x | `Record (_, fl, _) as x -> List.iter (check_field (Hashtbl.create 10)) fl; check_inheritance tbl x | `Tuple (_, tl, _) -> List.iter (fun (_, x, _) -> check x) tl | `List (_, t, _) -> check t | `Option (_, t, _) -> check t | `Nullable (_, t, _) -> check t | `Shared (loc, t, _) -> if Atd_ast.is_parametrized t then error_at loc "Shared type cannot be polymorphic"; check t | `Wrap (_, t, _) -> check t | `Name (_, (loc, k, tal), _) -> assert (k <> "list" && k <> "option" && k <> "nullable" && k <> "shared" && k <> "wrap"); let (arity, opt_def) = try Hashtbl.find tbl k with Not_found -> error_at loc ("Undefined type " ^ k) in let n = List.length tal in if arity <> n then error_at loc (sprintf "Type %s was defined to take %i parameters, \ but %i argument%s." k arity n (if n > 1 then "s are given" else " is given") ); List.iter check tal | `Tvar (loc, s) -> if not (List.mem s tvars) then error_at loc (sprintf "Unbound type variable '%s" s) and check_variant accu = function `Variant (loc, (k, _), opt_t) -> if Hashtbl.mem accu k then error_at loc (sprintf "Multiple definitions of the same variant constructor %s" k); Hashtbl.add accu k (); (match opt_t with None -> () | Some t -> check t) | `Inherit (_, t) -> (* overriding is allowed, for now without a warning *) check t and check_field accu = function `Field (loc, (k, fk, _), t) -> if Hashtbl.mem accu k then error_at loc (sprintf "Multiple definitions of the same field %s" k); Hashtbl.add accu k (); check t | `Inherit (_, t) -> (* overriding is allowed, for now without a warning *) check t in check t let check (l : Atd_ast.module_body) = let predef = Atd_predef.make_table () in let tbl = Hashtbl.copy predef in (* first pass: put all definitions in the table *) List.iter ( function `Type ((loc, (k, pl, a), t) as x) -> if Hashtbl.mem tbl k then if Hashtbl.mem predef k then error_at loc (sprintf "%s is a predefined type, it cannot be redefined." k) else error_at loc (sprintf "Type %s is defined for the second time." k) else Hashtbl.add tbl k (List.length pl, Some x) ) l; (* second pass: check existence and arity of types in type expressions, check that inheritance is not cyclic *) List.iter ( function `Type (loc, (k, tvars, a), t) -> check_type_expr tbl tvars t ) l; atd-1.1.1/atd_doc.ml000066400000000000000000000026361226670523100142240ustar00rootroot00000000000000open Printf 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 `Text (Atd_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 (fun s -> Some (Some (parse_text loc s))) None ["doc"] "text" an (* Conversion to HTML *) let html_escape buf s = String.iter ( function '<' -> Buffer.add_string buf "<" | '>' -> Buffer.add_string buf ">" | '&' -> Buffer.add_string buf "&" | '"' -> Buffer.add_string buf """ | c -> Buffer.add_char buf c ) s let print_inline buf = function `Text s -> html_escape buf s | `Code s -> bprintf buf "%a" html_escape s let html_of_doc (`Text blocks) = let buf = Buffer.create 300 in bprintf buf "\n
\n"; List.iter ( function `Paragraph l -> Buffer.add_string buf "

\n"; List.iter (print_inline buf) l; Buffer.add_string buf "\n

\n" | `Pre s -> Buffer.add_string buf "
\n";
          html_escape buf s;
          Buffer.add_string buf "
\n" ) blocks; bprintf buf "\n
\n"; Buffer.contents buf atd-1.1.1/atd_doc.mli000066400000000000000000000041241226670523100143670ustar00rootroot00000000000000(** 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 parse_text : Atd_ast.loc -> string -> doc (** Parse the contents of a doc.text annotation. *) val get_doc : Atd_ast.loc -> Atd_ast.annot -> doc option (** Get and parse doc data from annotations. *) val html_of_doc : doc -> string (** Convert parsed doc into HTML. *) atd-1.1.1/atd_doc_lexer.mll000066400000000000000000000063761226670523100156040ustar00rootroot00000000000000(* $Id: ag_doc_lexer.mll 48186 2010-09-09 22:24:27Z martin $ *) { 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 } atd-1.1.1/atd_expand.ml000066400000000000000000000432551226670523100147400ustar00rootroot00000000000000(* Monomorphization of type expressions. The goal is to inline each parametrized type definition as much as possible, allowing code generators to create more efficient code directly: type ('a, 'b) t = [ Foo of 'a | Bar of 'b ] type int_t = (int, int) t becomes: type int_t = _1 type _1 = [ Foo of int | Bar of int ] A secondary goal is to factor out type subexpressions in order for the code generators to produce less code: type x = { x : int list } type y = { y : int list option } becomes: type x = { x : _1 } type y = { y : _2 } type _1 = int list (* `int list' now occurs only once *) type _2 = _1 option By default, only parameterless type definitions are returned. The [keep_poly] option allows to return parametrized type definitions as well. Input: type 'a abs = abstract type int_abs = int abs type 'a tree = [ Leaf of 'a | Node of ('a tree * 'a tree) ] type t = int tree type x = [ Foo | Bar ] tree Output (pseudo-syntax where quoted strings indicate unique type identifiers): type "int abs" = int abs type int_abs = "int abs" type 'a tree = [ Leaf of 'a | Node of ('a tree * 'a tree) ] (* only if keep_poly = true *) type "int tree" = [ Leaf of int | Node of ("int tree" * "int tree") ] type t = "int tree" type "[ Foo | Bar ] tree" = [ Leaf of [ Foo | Bar ] | Node of ("[ Foo | Bar ] tree" * "[ Foo | Bar ] tree") ] type x = "[ Foo | Bar ] tree" *) open Printf open Atd_ast module S = Set.Make (String) module M = Map.Make (String) (* To support -o-name-overlap, we need to generate a few type annotations. But types generated by expansion like _1, _2, etc. are not actually written out in the interface or implementation, so they must be mapped back to the original polymorphic types for annotation purposes. This table contains the mappings. Its format is: key = generated type name value = (original type name, original number of parameters) For example, if we have the generated output: type 'a t = ... type _1 = int t Then the idea is, in the reader and writer functions, instead of using _1 in the annotation, we use _ t. The entry in original_types would be: ("_1", ("t", 1)) (The alternate strategy of actually producing a definition for type _1 aliasing int t in the implementation doesn't work, because the annotations will disagree with the interface in the case of recursive types.) *) type original_types = (string, string * int) Hashtbl.t (* Format of the table: key = type name (without arguments) value = (order in the file, number of parameters, original annotations of the right-hand type expression, original type definition, rewritten type definition) Every entry has an original type definition except the predefined atoms (int, string, etc.) and newly-created type definitions (type _1 = ...). *) let init_table () = let seqnum = ref 0 in let tbl = Hashtbl.create 20 in List.iter ( fun (k, n, opt_td) -> incr seqnum; Hashtbl.add tbl k (!seqnum, n, opt_td, None) ) Atd_predef.list; seqnum, tbl let rec mapvar_expr (f : string -> string) (x : Atd_ast.type_expr) : Atd_ast.type_expr = match x with `Sum (loc, vl, a) -> `Sum (loc, List.map (mapvar_variant f) vl, a) | `Record (loc, fl, a) -> `Record (loc, List.map (mapvar_field f) fl, a) | `Tuple (loc, tl, a) -> `Tuple (loc, List.map (fun (loc, x, a) -> (loc, mapvar_expr f x, a)) tl, a) | `List (loc, t, a) -> `List (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "list", [t]), a) -> `Name (loc, (loc2, "list", [mapvar_expr f t]), a) | `Option (loc, t, a) -> `Option (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "option", [t]), a) -> `Name (loc, (loc2, "option", [mapvar_expr f t]), a) | `Nullable (loc, t, a) -> `Nullable (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "nullable", [t]), a) -> `Name (loc, (loc2, "nullable", [mapvar_expr f t]), a) | `Shared (loc, t, a) -> `Shared (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "shared", [t]), a) -> `Name (loc, (loc2, "shared", [mapvar_expr f t]), a) | `Wrap (loc, t, a) -> `Wrap (loc, mapvar_expr f t, a) | `Name (loc, (loc2, "wrap", [t]), a) -> `Name (loc, (loc2, "wrap", [mapvar_expr f t]), a) | `Tvar (loc, s) -> `Tvar (loc, f s) | `Name (loc, (loc2, k, args), a) -> `Name (loc, (loc2, k, List.map (mapvar_expr f) args), a) and mapvar_field f = function `Field (loc, k, t) -> `Field (loc, k, mapvar_expr f t) | `Inherit (loc, t) -> `Inherit (loc, mapvar_expr f t) and mapvar_variant f = function `Variant (loc, k, opt_t) -> `Variant ( loc, k, (match opt_t with None -> None | Some t -> Some (mapvar_expr f t) ) ) | `Inherit (loc, t) -> `Inherit (loc, mapvar_expr f t) let var_of_int i = let letter = i mod 26 in let number = i / 26 in let prefix = String.make 1 (Char.chr (letter + Char.code 'a')) in if number = 0 then prefix else prefix ^ string_of_int number let vars_of_int n = Array.to_list (Array.init n var_of_int) let is_special s = String.length s > 0 && s.[0] = '@' (* Standardize a type expression by numbering the type variables using the order in which they are encountered. input: (int, 'b, 'z) foo output: - new_name: "@(int, 'a, 'b) foo" - new_args: [ 'b; 'z ] - new_env: [ ('b, 'a); ('z, 'b) ] new_name and new_args constitute the type expression that replaces the original one: (int, 'b, 'z) foo --> ('b, 'z) "@(int, 'a, 'b) foo" new_env allows the substitution of the type variables of the original type expression into the type variables defined by the new type definition. *) let make_type_name loc orig_name args an = let tbl = Hashtbl.create 10 in let n = ref 0 in let mapping = ref [] in let assign_name s = try Hashtbl.find tbl s with Not_found -> let name = var_of_int !n in mapping := (s, name) :: !mapping; incr n; name in let normalized_args = List.map (mapvar_expr assign_name) args in let new_name = "@(" ^ Atd_print.string_of_type_name orig_name normalized_args an ^ ")" in let mapping = List.rev !mapping in let new_args = List.map (fun (old_s, _) -> `Tvar (loc, old_s)) mapping in let new_env = List.map (fun (old_s, new_s) -> old_s, `Tvar (loc, new_s)) mapping in new_name, new_args, new_env let is_abstract (x : type_expr) = match x with `Name (_, (_, "abstract", _), _) -> true | _ -> false let expr_of_lvalue loc name param annot = `Name (loc, (loc, name, List.map (fun s -> `Tvar (loc, s)) param), annot) let is_cyclic lname t = match t with `Name (_, (_, rname, args), _) -> lname = rname | _ -> false let is_tvar = function `Tvar _ -> true | _ -> false let add_annot (x : type_expr) a : type_expr = Atd_ast.map_annot (fun a0 -> Atd_annot.merge (a @ a0)) x let expand ?(keep_poly = false) (l : type_def list) : type_def list * original_types = let seqnum, tbl = init_table () in let original_types = Hashtbl.create 16 in let rec subst env (t : type_expr) : type_expr = match t with `Sum (loc, vl, a) -> `Sum (loc, List.map (subst_variant env) vl, a) | `Record (loc, fl, a) -> `Record (loc, List.map (subst_field env) fl, a) | `Tuple (loc, tl, a) -> `Tuple (loc, List.map (fun (loc, x, a) -> (loc, subst env x, a)) tl, a) | `List (loc as loc2, t, a) | `Name (loc, (loc2, "list", [t]), a) -> let t' = subst env t in subst_type_name loc loc2 "list" [t'] a | `Option (loc as loc2, t, a) | `Name (loc, (loc2, "option", [t]), a) -> let t' = subst env t in subst_type_name loc loc2 "option" [t'] a | `Nullable (loc as loc2, t, a) | `Name (loc, (loc2, "nullable", [t]), a) -> let t' = subst env t in subst_type_name loc loc2 "nullable" [t'] a | `Shared (loc as loc2, t, a) | `Name (loc, (loc2, "shared", [t]), a) -> let t' = subst env t in subst_type_name loc loc2 "shared" [t'] a | `Wrap (loc as loc2, t, a) | `Name (loc, (loc2, "wrap", [t]), a) -> let t' = subst env t in subst_type_name loc loc2 "wrap" [t'] a | `Tvar (loc, s) as x -> (try List.assoc s env with Not_found -> x) | `Name (loc, (loc2, name, args), a) -> let args' = List.map (subst env) args in if List.for_all is_tvar args' then `Name (loc, (loc2, name, args'), a) else subst_type_name loc loc2 name args' a and subst_type_name loc loc2 name args an = (* Reduce the number of arguments of the type by creating an intermediate type, e.g.: ('x, int) t becomes 'x "('a, int) t" and the following type is created: type 'a "('a, int) t" = ... input: - type name with arguments expressed in the environment where the type expression was extracted - annotations for that type expression output: - equivalent type expression valid in the same environment side-effects: - creation of a type definition for the output type expression. *) let new_name, new_args, new_env = make_type_name loc2 name args an in let n_param = List.length new_env in if not (Hashtbl.mem tbl new_name) then create_type_def loc name args new_env new_name n_param an; (* Return new type name with new arguments. The annotation has been transferred to the right-hand expression of the new type definition. *) `Name (loc, (loc2, new_name, new_args), []) and create_type_def loc orig_name orig_args env name n_param an0 = (* Create the type definition needed to support the new type name [name] expecting [n_param] parameters. The right-hand side of the definition is obtained by looking up the definition for type [orig_name]: type ('a, 'b) t = [ Foo of 'a | Bar of 'b ] type 'c it = (int, 'c) t output: type ('a, 'b) t = [ Foo of 'a | Bar of 'b ] type 'a _1 = [ Foo of int | Bar of 'a ] (* new name = _1, n_param = 1 *) type 'c it = 'c _1 *) incr seqnum; let i = !seqnum in (* Create entry in the table, indicating that we are working on it *) Hashtbl.add tbl name (i, n_param, None, None); Hashtbl.add original_types name (orig_name, List.length orig_args); (* Get the original type definition *) let (_, n, orig_opt_td, new_opt_td) = try Hashtbl.find tbl orig_name with Not_found -> assert false (* All original type definitions must have been put in the table initially *) in let ((_, _, t') as td') = match orig_opt_td with None -> assert false (* Original type definitions must all exist, even for predefined types and abstract types. *) | Some (orig_loc, (k, pl, def_an), t) -> assert (k = orig_name); let new_params = vars_of_int n_param in let t = add_annot t an0 in let t = set_type_expr_loc loc t in (* First replace the type expression being specialized (orig_name, orig_args) by the equivalent expression in the new environment (variables 'a, 'b, ...) (int, 'b) foo --> (int, 'a) foo *) let args = List.map (subst env) orig_args in (* Then expand the expression into its definition, replacing each variable by the actual argument: original definition: type ('x, 'y) foo = [ Foo of 'x | Bar of 'y ] new definition: type 'a _1 = ... right-hand expression becomes: [ Foo of int | Bar of 'a ] using the following environment: 'x -> int 'y -> 'a *) let env = List.map2 (fun var value -> (var, value)) pl args in let t' = if is_abstract t then (* e.g.: type 'a t = abstract use 'a t and preserve "t" *) let t = expr_of_lvalue loc orig_name pl (Atd_ast.annot_of_type_expr t) in subst_only_args env t else let t' = subst env t in if is_cyclic name t' then subst_only_args env t else t' in (loc, (name, new_params, def_an), t') in Hashtbl.replace tbl name (i, n_param, None, Some td') and subst_field env = function `Field (loc, k, t) -> `Field (loc, k, subst env t) | `Inherit (loc, t) -> `Inherit (loc, subst env t) and subst_variant env = function `Variant (loc, k, opt_t) as x -> (match opt_t with None -> x | Some t -> `Variant (loc, k, Some (subst env t)) ) | `Inherit (loc, t) -> `Inherit (loc, subst env t) and subst_only_args env = function `List (loc, t, a) | `Name (loc, (_, "list", [t]), a) -> `List (loc, subst env t, a) | `Option (loc, t, a) | `Name (loc, (_, "option", [t]), a) -> `Option (loc, subst env t, a) | `Nullable (loc, t, a) | `Name (loc, (_, "nullable", [t]), a) -> `Nullable (loc, subst env t, a) | `Shared (loc, t, a) | `Name (loc, (_, "shared", [t]), a) -> `Shared (loc, subst env t, a) | `Wrap (loc, t, a) | `Name (loc, (_, "wrap", [t]), a) -> `Wrap (loc, subst env t, a) | `Name (loc, (loc2, name, args), an) -> `Name (loc, (loc2, name, List.map (subst env) args), an) | _ -> assert false in (* first pass: add all original definitions to the table *) List.iter ( fun ((_, (k, pl, _), x) as td) -> incr seqnum; let i = !seqnum in let n = List.length pl in Hashtbl.add tbl k (i, n, Some td, None) ) l; (* second pass: perform substitutions and insert new definitions *) List.iter ( fun ((loc, (k, pl, a), t) as td) -> if pl = [] || keep_poly then ( let (i, n, _, _) = try Hashtbl.find tbl k with Not_found -> assert false in let t' = subst [] t in let td' = (loc, (k, pl, a), t') in Hashtbl.replace tbl k (i, n, Some td, Some td') ) ) l; (* third pass: collect all parameterless definitions *) let l = Hashtbl.fold ( fun k (i, n, opt_td, opt_td') l -> match opt_td' with None -> l | Some td' -> if n = 0 || keep_poly then (i, td') :: l else l ) tbl [] in let l = List.sort (fun (i, _) (j, _) -> compare i j) l in (List.map snd l, original_types) let replace_type_names (subst : string -> string) (t : type_expr) : type_expr = let rec replace (t : type_expr) : type_expr = match t with `Sum (loc, vl, a) -> `Sum (loc, List.map replace_variant vl, a) | `Record (loc, fl, a) -> `Record (loc, List.map replace_field fl, a) | `Tuple (loc, tl, a) -> `Tuple (loc, List.map (fun (loc, x, a) -> loc, replace x, a) tl, a) | `List (loc, t, a) -> `List (loc, replace t, a) | `Option (loc, t, a) -> `Option (loc, replace t, a) | `Nullable (loc, t, a) -> `Nullable (loc, replace t, a) | `Shared (loc, t, a) -> `Shared (loc, replace t, a) | `Wrap (loc, t, a) -> `Wrap (loc, replace t, a) | `Tvar (loc, s) as t -> t | `Name (loc, (loc2, k, l), a) -> `Name (loc, (loc2, subst k, List.map replace l), a) and replace_field = function `Field (loc, k, t) -> `Field (loc, k, replace t) | `Inherit (loc, t) -> `Inherit (loc, replace t) and replace_variant = function `Variant (loc, k, opt_t) as x -> (match opt_t with None -> x | Some t -> `Variant (loc, k, Some (replace t)) ) | `Inherit (loc, t) -> `Inherit (loc, replace t) in replace t let standardize_type_names ~prefix ~original_types (l : type_def list) : type_def list = let new_id = let n = ref 0 in let rec f tbl = incr n; let id = prefix ^ string_of_int !n in if Hashtbl.mem tbl id then f tbl else id in f in let tbl = Hashtbl.create 50 in List.iter (fun (k, _, _) -> Hashtbl.add tbl k k) Atd_predef.list; List.iter ( fun (_, (k, _, _), _) -> if not (is_special k) then ( Hashtbl.add tbl k k ) ) l; let replace_name k = try Hashtbl.find tbl k with Not_found -> assert (is_special k); let k' = new_id tbl in Hashtbl.add tbl k k'; begin try let orig_info = Hashtbl.find original_types k in Hashtbl.remove original_types k; Hashtbl.add original_types k' orig_info with Not_found -> assert false (* Must have been added during expand *) end; k' in let l = List.map ( fun (loc, (k, pl, a), t) -> let k' = replace_name k in (loc, (k', pl, a), t) ) l in let subst s = try Hashtbl.find tbl s with Not_found -> (* must have been defined as abstract *) s in List.map (fun (loc, x, t) -> (loc, x, replace_type_names subst t)) l let expand_module_body ?(prefix = "_") ?keep_poly ?(debug = false) l = let td_list = List.map (function `Type td -> td) l in let (td_list, original_types) = expand ?keep_poly td_list in let td_list = if debug then td_list else standardize_type_names ~prefix ~original_types td_list in (List.map (fun td -> `Type td) td_list, original_types) atd-1.1.1/atd_expand.mli000066400000000000000000000046461226670523100151120ustar00rootroot00000000000000 (** Monomorphization of type definitions *) type original_types = (string, string * int) Hashtbl.t (** To support the generation of annotations for types that are created during the monomorphization process, a mapping must be kept connecting the monomorphic type name to the original polymorphic one, including its original number of parameters. This table is only used in producing those annotations to support the Atdgen command line option -o-name-overlap. It can probably be ignored for most uses of expand_module_body. *) val expand_module_body : ?prefix:string -> ?keep_poly:bool -> ?debug:bool -> Atd_ast.module_body -> Atd_ast.module_body * original_types (** Monomorphization of type expressions. @param prefix prefix to use for new type names. Default is ["_"]. @param keep_poly return definitions for the parametrized types. Default is [false]. @param debug keep meaningful but non ATD-compliant names for new type names. Default is [false]. The goal is to inline each parametrized type definition as much as possible, allowing code generators to create more efficient code directly: {v type ('a, 'b) t = [ Foo of 'a | Bar of 'b ] type int_t = (int, int) t v} becomes: {v type int_t = _1 type _1 = [ Foo of int | Bar of int ] v} A secondary goal is to factor out type subexpressions in order for the code generators to produce less code: {v type x = \{ x : int list } type y = \{ y : int list option } v} becomes: {v type x = \{ x : _1 } type y = \{ y : _2 } type _1 = int list (* `int list' now occurs only once *) type _2 = _1 option v} By default, only parameterless type definitions are returned. The [keep_poly] option allows to return parametrized type definitions as well. Input: {v type 'a abs = abstract type int_abs = int abs type 'a tree = [ Leaf of 'a | Node of ('a tree * 'a tree) ] type t = int tree type x = [ Foo | Bar ] tree v} Output (pseudo-syntax where quoted strings indicate unique type identifiers): {v type "int abs" = int abs type int_abs = "int abs" type 'a tree = [ Leaf of 'a | Node of ('a tree * 'a tree) ] (* only if keep_poly = true *) type "int tree" = [ Leaf of int | Node of ("int tree" * "int tree") ] type t = "int tree" type "[ Foo | Bar ] tree" = [ Leaf of [ Foo | Bar ] | Node of ("[ Foo | Bar ] tree" * "[ Foo | Bar ] tree") ] type x = "[ Foo | Bar ] tree" v} *) atd-1.1.1/atd_indent.ml000066400000000000000000000014301226670523100147270ustar00rootroot00000000000000 type t = [ | `Line of string | `Block of t list | `Inline of t list ] let to_buffer ?(offset = 0) ?(indent = 2) buf l = let rec print n = function `Block l -> List.iter (print (n + indent)) l | `Inline l -> List.iter (print n) l | `Line s -> for i = 1 to n do Buffer.add_char buf ' ' done; Buffer.add_string buf s; Buffer.add_char buf '\n'; in List.iter (print offset) l let to_string ?offset ?indent l = let buf = Buffer.create 1000 in to_buffer ?offset ?indent buf l; Buffer.contents buf let to_channel ?offset ?indent oc l = let buf = Buffer.create 1000 in to_buffer ?offset ?indent buf l; Buffer.output_buffer oc buf let to_stdout ?offset ?indent l = to_channel ?offset ?indent stdout l atd-1.1.1/atd_indent.mli000066400000000000000000000023031226670523100151000ustar00rootroot00000000000000 (** Simple indentation utility for code generators *) type t = [ | `Line of string | `Block of t list | `Inline of t list ] (** [t] is the type of the data to be printed. - [`Line]: single line (not indented) - [`Block]: indented sequence - [`Inline]: in-line sequence (not indented) Example: {v let l = [ `Line "d"; `Line "e"; ] in [ `Line "a"; `Block [ `Line "b"; `Line "c"; ]; `Inline l; `Line "f"; ] v} gives: {v a b c d e f v} *) val to_buffer : ?offset:int -> ?indent:int -> Buffer.t -> t list -> unit (** Write to a buffer. @param offset defines the number of space characters to use for the left margin. Default: 0. @param indent defines the number of space characters to use for indenting blocks. Default: 2. *) val to_string : ?offset:int -> ?indent:int -> t list -> string (** Write to a string. See [to_buffer] for the options. *) val to_channel : ?offset:int -> ?indent:int -> out_channel -> t list -> unit (** Write to a channel. See [to_buffer] for the options. *) val to_stdout : ?offset:int -> ?indent:int -> t list -> unit (** Write to [stdout]. See [to_buffer] for the options. *) atd-1.1.1/atd_inherit.ml000066400000000000000000000100251226670523100151100ustar00rootroot00000000000000(* Perform inheritance. *) open Printf open Atd_ast module S = Set.Make (String) let load_defs l = let tbl = Atd_predef.make_table () in List.iter ( fun ((_, (k, pl, _), _) as td) -> Hashtbl.add tbl k (List.length pl, Some td) ) l; tbl let keep_last_defined get_name l = let set, l = List.fold_right ( fun x (set, l) -> let k = get_name x in if S.mem k set then (set, l) else (S.add k set, x :: l) ) l (S.empty, []) in l let get_field_name : field -> string = function `Field (loc, (k, _, _), _) -> k | `Inherit _ -> assert false let get_variant_name : variant -> string = function `Variant (loc, (k, _), _) -> k | `Inherit _ -> assert false let expand ?(inherit_fields = true) ?(inherit_variants = true) tbl t0 = let rec subst deref param (t : type_expr) : type_expr = match t with `Sum (loc, vl, a) -> let vl = List.flatten (List.map (subst_variant param) vl) in let vl = if inherit_variants then keep_last_defined get_variant_name vl else vl in `Sum (loc, vl, a) | `Record (loc, fl, a) -> let fl = List.flatten (List.map (subst_field param) fl) in let fl = if inherit_fields then keep_last_defined get_field_name fl else fl in `Record (loc, fl, a) | `Tuple (loc, tl, a) -> `Tuple ( loc, List.map (fun (loc, x, a) -> (loc, subst false param x, a)) tl, a ) | `List (loc, t, a) | `Name (loc, (_, "list", [t]), a) -> `List (loc, subst false param t, a) | `Option (loc, t, a) | `Name (loc, (_, "option", [t]), a) -> `Option (loc, subst false param t, a) | `Nullable (loc, t, a) | `Name (loc, (_, "nullable", [t]), a) -> `Nullable (loc, subst false param t, a) | `Shared (loc, t, a) | `Name (loc, (_, "shared", [t]), a) -> `Shared (loc, subst false param t, a) | `Wrap (loc, t, a) | `Name (loc, (_, "wrap", [t]), a) -> `Wrap (loc, subst false param t, a) | `Tvar (loc, s) -> (try List.assoc s param with Not_found -> t) | `Name (loc, (loc2, k, args), a) -> let expanded_args = List.map (subst false param) args in if deref then let k, vars, a, t = try match Hashtbl.find tbl k with n, Some (_, (k, vars, a), t) -> k, vars, a, t | n, None -> failwith ("Cannot inherit from type " ^ k) with Not_found -> failwith ("Missing type definition for " ^ k) in let param = List.combine vars expanded_args in subst true param t else `Name (loc, (loc2, k, expanded_args), a) and subst_field param = function `Field (loc, k, t) -> [ `Field (loc, k, subst false param t) ] | `Inherit (loc, t) as x -> (match subst true param t with `Record (loc, vl, a) -> if inherit_fields then vl else [ x ] | _ -> failwith "Not a record type" ) and subst_variant param = function `Variant (loc, k, opt_t) as x -> (match opt_t with None -> [ x ] | Some t -> [ `Variant (loc, k, Some (subst false param t)) ] ) | `Inherit (loc, t) as x -> (match subst true param t with `Sum (loc, vl, a) -> if inherit_variants then vl else [ x ] | _ -> failwith "Not a sum type" ) in subst false [] t0 let expand_module_body ?inherit_fields ?inherit_variants (l : Atd_ast.module_body) = let td_list = List.map (function `Type td -> td) l in let tbl = load_defs td_list in let td_list = List.map ( fun (loc, name, t) -> (loc, name, expand ?inherit_fields ?inherit_variants tbl t) ) td_list in List.map (fun td -> `Type td) td_list atd-1.1.1/atd_inherit.mli000066400000000000000000000007041226670523100152640ustar00rootroot00000000000000 (** Expansion of [inherit] statements *) val expand_module_body : ?inherit_fields : bool -> ?inherit_variants : bool -> Atd_ast.module_body -> Atd_ast.module_body (** Expand [inherit] statements found in sum types and product types. @param inherit_fields specify whether record fields should be expanded. Default is true. @param inherit_variants specify whether sum types should be expanded. Default is true. *) atd-1.1.1/atd_lexer.mll000066400000000000000000000120221226670523100147400ustar00rootroot00000000000000 { open Printf open Lexing open Atd_parser let lexing_error lexbuf msg = let loc = (lexeme_start_p lexbuf, lexeme_end_p lexbuf) in Atd_ast.error (Atd_ast.string_of_loc loc ^ "\n" ^ msg) type accu = { mutable depth : int; buf : Buffer.t } let newline lexbuf = let pos = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } let int_of_dec c = match c with '0'..'9' -> Char.code c - 48 | _ -> invalid_arg "int_of_dec" let int_of_hex c = match c with '0'..'9' -> Char.code c - 48 | 'a'..'f' -> Char.code c - 87 | 'A'..'F' -> Char.code c - 55 | _ -> invalid_arg "int_of_hex" let byte_of_hex a b = Char.chr (int_of_hex a lsl 4 + int_of_hex b) let byte_of_dec a b c = let x = int_of_dec a * 100 + int_of_dec b * 10 + int_of_dec c in if x > 255 then invalid_arg "byte_of_dec" else Char.chr x let utf8_of_hex4 buf b1 b2 b3 b4 = (* covers only U+0000-U+FFFF *) let a = int_of_hex b1 lsl 4 + int_of_hex b2 in let b = int_of_hex b3 lsl 4 + int_of_hex b4 in let u = a lsl 8 + b in let add buf i = Buffer.add_char buf (Char.chr (i land 0xff)) in if u <= 0x007f then add buf u else if u <= 0x07ff then ( add buf (0b11000000 lor (a lsl 2) lor (b lsr 6)); add buf (0b10000000 lor (b land 0b00111111)) ) else if u <= 0xffff then ( add buf (0b11100000 lor (a lsr 4)); add buf (0b10000000 lor ((a lsl 2) land 0b00111100) lor (b lsr 6)); add buf (0b10000000 lor (b land 0b00111111)) ) else invalid_arg "utf8_of_hex4" (* let test_utf8_of_hex s = assert (String.length s = 4); let buf = Buffer.create 10 in utf8_of_hex4 buf s.[0] s.[1] s.[2] s.[3]; let file = Filename.temp_file "debug" "" in let oc = open_out file in output_string oc (Buffer.contents buf); close_out oc; assert (Sys.command ("xxd -b " ^ file) = 0); Sys.remove file *) ;; } let upper = ['A'-'Z'] let lower = ['a'-'z'] let digit = ['0'-'9'] let identchar = upper | lower | digit | ['_' '\''] let hex = ['0'-'9' 'a'-'f' 'A'-'F'] let lident = (lower | '_' identchar) identchar* let uident = upper identchar* let blank = [ ' ' '\t' ] let newline = '\r'? '\n' let space = [ ' ' '\t' '\r' '\n' ] rule token = parse | "(" { OP_PAREN } | ")" { CL_PAREN } | "[" { OP_BRACK } | "]" { CL_BRACK } | "{" { OP_CURL } | "}" { CL_CURL } | "<" { LT } | ">" { GT } | ";" { SEMICOLON } | "," { COMMA } | ":" { COLON } | "*" { STAR } | "|" { BAR } | "=" { EQ } | "?" { QUESTION } | "~" { TILDE } | "type" { TYPE } | "of" { OF } | "inherit" { INHERIT } | lident as s { LIDENT s } | uident as s { UIDENT s } | "'" (lident as s) { TIDENT s } | newline { newline lexbuf; token lexbuf } | blank+ { token lexbuf } | eof { EOF } | '"' { STRING (string (Buffer.create 200) lexbuf) } | "(*" { comment 1 lexbuf; token lexbuf } | _ as c { lexing_error lexbuf (sprintf "Illegal character %S" (String.make 1 c)) } and string buf = parse | '"' { Buffer.contents buf } | '\\' (['\\' '"'] as c) { Buffer.add_char buf c; string buf lexbuf } | "\\x" (hex as a) (hex as b) { Buffer.add_char buf (byte_of_hex a b); string buf lexbuf } | '\\' (digit as a) (digit as b) (digit as c) { Buffer.add_char buf (byte_of_dec a b c); string buf lexbuf } | "\\n" { Buffer.add_char buf '\n'; string buf lexbuf } | "\\r" { Buffer.add_char buf '\r'; string buf lexbuf } | "\\t" { Buffer.add_char buf '\t'; string buf lexbuf } | "\\b" { Buffer.add_char buf '\b'; string buf lexbuf } | '\n' { newline lexbuf; Buffer.add_char buf '\n'; string buf lexbuf } | '\\' newline blank* { newline lexbuf; string buf lexbuf } | '\\' { lexing_error lexbuf "Invalid escape sequence" } | _ as c { Buffer.add_char buf c; string buf lexbuf } | eof { lexing_error lexbuf "Unterminated string" } and comment depth = parse | "*)" { if depth > 1 then comment (depth - 1) lexbuf } | "(*" { comment (depth + 1) lexbuf } | '"' { ignore (string (Buffer.create 200) lexbuf); comment depth lexbuf } | newline { newline lexbuf; comment depth lexbuf } | _ { comment depth lexbuf } | eof { lexing_error lexbuf "Unterminated comment" } { let init_fname lexbuf fname lnum = lexbuf.lex_start_p <- { lexbuf.lex_start_p with pos_fname = fname; pos_lnum = lnum }; lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fname; pos_lnum = lnum } } atd-1.1.1/atd_parser.mly000066400000000000000000000137551226670523100151500ustar00rootroot00000000000000/* ATD Parser requires menhir. */ %{ open Printf open Atd_ast let syntax_error s pos1 pos2 = let msg = sprintf "%s:\n%s" (string_of_loc (pos1, pos2)) s in error msg %} %token TYPE EQ OP_PAREN CL_PAREN OP_BRACK CL_BRACK OP_CURL CL_CURL SEMICOLON COMMA COLON STAR OF EOF BAR LT GT INHERIT QUESTION TILDE %token < string > STRING LIDENT UIDENT TIDENT %start full_module %type < Atd_ast.full_module > full_module %% full_module: | x = annot y = module_body { ((($startpos(x), $endpos(x)), x), y) } ; module_body: | module_item module_body { $1 :: $2 } | EOF { [] } | _e=error { syntax_error "Syntax error" $startpos(_e) $endpos(_e) } ; annot: | x = asection l = annot { x :: l } | { ([] : annot) } ; asection: | LT x = LIDENT l = afield_list GT { (x, (($startpos, $endpos), l)) } | LT LIDENT afield_list _e=error { syntax_error "Expecting '>'" $startpos(_e) $endpos(_e) } | LT _e=error { syntax_error "Expecting lowercase identifier" $startpos(_e) $endpos(_e) } ; afield_list: | x = afield l = afield_list { x :: l } | { [] } ; afield: | LIDENT EQ STRING { ($1, (($startpos, $endpos), Some $3)) } | LIDENT { ($1, (($startpos, $endpos), None)) } ; module_item: | TYPE p = type_param s = LIDENT a = annot EQ t = type_expr { `Type (($startpos, $endpos), (s, p, a), t) } | TYPE type_param LIDENT annot EQ _e=error { syntax_error "Expecting type expression" $startpos(_e) $endpos(_e) } | TYPE type_param LIDENT annot _e=error { syntax_error "Expecting '='" $startpos(_e) $endpos(_e) } | TYPE _e=error { syntax_error "Expecting type name" $startpos(_e) $endpos(_e) } ; type_param: | TIDENT { [ $1 ] } | OP_PAREN type_var_list CL_PAREN { $2 } | { [] } | OP_PAREN type_var_list _e=error { syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) } ; type_var_list: | TIDENT COMMA type_var_list { $1 :: $3 } | TIDENT { [ $1 ] } ; type_expr: | OP_BRACK l = variant_list CL_BRACK a = annot { `Sum (($startpos, $endpos), l, a) } | OP_BRACK CL_BRACK a = annot { `Sum (($startpos, $endpos), [], a) } | OP_CURL l = field_list CL_CURL a = annot { `Record (($startpos, $endpos), l, a) } | OP_CURL CL_CURL a = annot { `Record (($startpos, $endpos), [], a) } | OP_PAREN l = cartesian_product CL_PAREN a = annot { `Tuple (($startpos, $endpos), l, a) } | x = type_inst a = annot { let pos1 = $startpos in let pos2 = $endpos in let loc = (pos1, pos2) in let loc2, name, args = x in match name, args with "list", [x] -> `List (loc, x, a) | "option", [x] -> `Option (loc, x, a) | "nullable", [x] -> `Nullable (loc, x, a) | "shared", [x] -> let a = if Atd_annot.has_field ["share"] "id" a then (* may cause ID clashes if not used properly *) a else Atd_annot.set_field loc "share" "id" (Some (Atd_annot.create_id ())) a in `Shared (loc, x, a) | "wrap", [x] -> `Wrap (loc, x, a) | ("list"|"option"|"nullable"|"shared"|"wrap"), _ -> syntax_error (sprintf "%s expects one argument" name) pos1 pos2 | _ -> (`Name (loc, x, a) : type_expr) } | x = TIDENT { `Tvar (($startpos, $endpos), x) } | OP_BRACK variant_list _e=error { syntax_error "Expecting ']'" $startpos(_e) $endpos(_e) } | OP_CURL field_list _e=error { syntax_error "Expecting '}'" $startpos(_e) $endpos(_e) } | OP_PAREN cartesian_product _e=error { syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) } ; cartesian_product: | x = annot_expr STAR l = cartesian_product { x :: l } | x = annot_expr STAR y = annot_expr { [ x; y ] } | x = annot_expr { [ x ] } | { [] } ; annot_expr: | a = annot COLON x = type_expr { (($startpos, $endpos), x, a) } | x = type_expr { (($startpos, $endpos), x, []) } ; type_inst: | l = type_args s = LIDENT { (($startpos, $endpos), s, l) } ; type_args: | type_expr { [ $1 ] } | OP_PAREN type_arg_list CL_PAREN { $2 } | { [] } | OP_PAREN type_arg_list _e=error { syntax_error "Expecting ')'" $startpos(_e) $endpos(_e) } ; type_arg_list: | type_expr COMMA type_arg_list { $1 :: $3 } | type_expr { [ $1 ] } ; variant_list: | BAR variant_list0 { $2 } | variant_list0 { $1 } ; variant_list0: | variant BAR variant_list0 { $1 :: $3 } | variant { ([ $1 ] : variant list) } ; variant: | x = UIDENT a = annot OF t = type_expr { `Variant (($startpos, $endpos), (x, a), Some t) } | x = UIDENT a = annot { `Variant (($startpos, $endpos), (x, a), None) } | INHERIT t = type_expr { `Inherit (($startpos, $endpos), t) } | UIDENT annot OF _e=error { syntax_error "Expecting type expression after 'of'" $startpos(_e) $endpos(_e) } ; field_list: | x = field SEMICOLON l = field_list { x :: l } | x = field SEMICOLON { [ x ] } | x = field { [ x ] } ; field: | fn = field_name a = annot COLON t = type_expr { let k, fk = fn in `Field (($startpos, $endpos), (k, fk, a), t) } | INHERIT t = type_expr { `Inherit (($startpos, $endpos), t) } | field_name annot COLON _e=error { syntax_error "Expecting type expression after ':'" $startpos(_e) $endpos(_e) } | field_name annot _e=error { syntax_error "Expecting ':'" $startpos(_e) $endpos(_e) } ; field_name: | k = LIDENT { (k, `Required) } | QUESTION k = LIDENT { (k, `Optional) } | TILDE k = LIDENT { (k, `With_default) } ; atd-1.1.1/atd_predef.ml000066400000000000000000000022521226670523100147160ustar00rootroot00000000000000(* Table of predefined types. *) open Atd_ast let list_def : type_def = let loc = dummy_loc in ( loc, ("list", ["a"], []), `List (loc, `Tvar (loc, "a"), []) ) let option_def : type_def = let loc = dummy_loc in ( loc, ("option", ["a"], []), `Option (loc, `Tvar (loc, "a"), []) ) let nullable_def : type_def = let loc = dummy_loc in ( loc, ("nullable", ["a"], []), `Nullable (loc, `Tvar (loc, "a"), []) ) let shared_def : type_def = let loc = dummy_loc in ( loc, ("shared", ["a"], []), `Shared (loc, `Tvar (loc, "a"), []) ) let wrap_def : type_def = let loc = dummy_loc in ( loc, ("wrap", ["a"], []), `Wrap (loc, `Tvar (loc, "a"), []) ) let list = [ "unit", 0, None; "bool", 0, None; "int", 0, None; "float", 0, None; "string", 0, None; "abstract", 0, None; "list", 1, Some list_def; "option", 1, Some option_def; "nullable", 1, Some nullable_def; "shared", 1, Some shared_def; "wrap", 1, Some wrap_def; ] let make_table () = let tbl = Hashtbl.create 20 in List.iter ( fun (k, n, opt_t) -> Hashtbl.add tbl k (n, opt_t) ) list; tbl atd-1.1.1/atd_print.ml000066400000000000000000000144321226670523100146100ustar00rootroot00000000000000open Easy_format open Atd_ast 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 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 quote_string s = Printf.sprintf "%S" s let format_prop (k, (_, opt)) = match opt with None -> make_atom k | Some s -> Label ( (make_atom (k ^ "="), label0), (make_atom (quote_string s)) ) let default_annot (s, (_, l)) = match l with [] -> make_atom ("<" ^ s ^ ">") | l -> List ( ("<", "", ">", plist), [ Label ( (make_atom s, label), List ( ("", "", "", plist), List.map format_prop l ) ) ] ) let string_of_field k fk = match fk with `Required -> k | `Optional -> "?" ^ k | `With_default -> "~" ^ k let make_closures format_annot = let append_annots (l : annot) x = match l with [] -> x | _ -> Label ( (x, label), List (("", "", "", plist), List.map format_annot l) ) in let prepend_colon_annots l x = match l with [] -> x | _ -> Label ( (Label ( (List (("", "", "", plist), List.map format_annot l), label0), make_atom ":" ), label), x ) in let rec format_module_item (x : module_item) = match x with `Type (_, (s, param, a), t) -> let left = if a = [] then let l = make_atom "type" :: prepend_type_param param [ make_atom (s ^ " =") ] in horizontal_sequence l else let l = make_atom "type" :: prepend_type_param param [ make_atom s ] in let x = append_annots a (horizontal_sequence l) in horizontal_sequence [ x; make_atom "=" ] in Label ( (left, label), format_type_expr t ) 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 (_, l, a) -> append_annots a ( List ( ("[", "|", "]", llist), List.map format_variant l ) ) | `Record (_, l, a) -> append_annots a ( List ( ("{", ";", "}", list), List.map format_field l ) ) | `Tuple (_, l, a) -> append_annots a ( List ( ("(", "*", ")", lplist), List.map format_tuple_field l ) ) | `List (loc, t, a) -> format_type_name "list" [t] a | `Option (loc, t, a) -> format_type_name "option" [t] a | `Nullable (loc, t, a) -> format_type_name "nullable" [t] a | `Shared (loc, t, a) -> format_type_name "shared" [t] a | `Wrap (loc, t, a) -> format_type_name "wrap" [t] a | `Name (_, (_, name, args), a) -> format_type_name name args a | `Tvar (_, name) -> make_atom ("'" ^ name) and format_type_name name args a = append_annots a ( horizontal_sequence (prepend_type_args args [ make_atom name ]) ) and format_inherit t = horizontal_sequence [ make_atom "inherit"; format_type_expr t ] and format_tuple_field (loc, x, a) = prepend_colon_annots a (format_type_expr x) and format_field x = match x with `Field (_, (k, fk, a), t) -> Label ( (horizontal_sequence0 [ append_annots a (make_atom (string_of_field k fk)); make_atom ":" ], label), format_type_expr t ) | `Inherit (_, t) -> format_inherit t and format_variant x = match x with `Variant (_, (k, a), opt) -> let cons = append_annots a (make_atom k) in (match opt with None -> cons | Some t -> Label ( (cons, label), Label ( (make_atom "of", label), format_type_expr t ) ) ) | `Inherit (_, t) -> format_inherit t in let format_full_module ((loc, an), l) = List ( ("", "", "", rlist), List.map format_annot an @ List.map format_module_item l ) in format_full_module, format_type_name let format ?(annot = default_annot) x = let f, _ = make_closures annot in f x let default_format, default_format_type_name = make_closures default_annot let string_of_type_name name args an = let x = default_format_type_name name args an in Easy_format.Pretty.to_string x atd-1.1.1/atd_print.mli000066400000000000000000000013241226670523100147550ustar00rootroot00000000000000 (** Pretty-printing of ATD data *) val default_annot : Atd_ast.annot_section -> Easy_format.t val format : ?annot: (Atd_ast.annot_section -> Easy_format.t) -> Atd_ast.full_module -> Easy_format.t (** Pretty-printing. Use the functions of the [Easy_format.Pretty] module to convert an [Easy_format.t] into a string or add it to a channel or buffer. @param annot can be used to specify another way of formatting annotations. The default is available as [default_format_annot]. *) val string_of_type_name : string -> Atd_ast.type_expr list -> Atd_ast.annot -> string (** Convert a type name with its arguments and its annotations into a string. *) atd-1.1.1/atd_reflect.ml000066400000000000000000000112641226670523100151000ustar00rootroot00000000000000(* Conversion of an ATD tree to OCaml source code for that value. *) open Printf let print_loc buf (pos1, pos2) = bprintf buf "loc" let print_list f buf l = bprintf buf "["; List.iter (fun x -> bprintf buf "%a;\n" f x) l; bprintf buf "]" let print_opt f buf o = match o with None -> bprintf buf "None" | Some x -> bprintf buf "Some (%a)" f x let print_qstring buf s = bprintf buf "%S" s let print_prop_list buf l = print_list ( fun buf (s, (loc, o)) -> bprintf buf "(%S, (%a, %a))" s print_loc loc (print_opt print_qstring) o ) buf l let print_annot_list buf l = print_list ( fun buf (s, (loc, l)) -> bprintf buf "(%S, (%a, %a))" s print_loc loc print_prop_list l ) buf l let rec print_type_expr buf (x : Atd_ast.type_expr) = match x with `Sum (loc, variant_list, annot_list) -> bprintf buf "`Sum (%a, %a, %a)" print_loc loc (print_list print_variant) variant_list print_annot_list annot_list | `Record (loc, field_list, annot_list) -> bprintf buf "`Record (%a, %a, %a)" print_loc loc (print_list print_field) field_list print_annot_list annot_list | `Tuple (loc, cell_list, annot_list) -> bprintf buf "`Tuple (%a, %a, %a)" print_loc loc (print_list print_cell) cell_list print_annot_list annot_list | `List (loc, type_expr, annot_list) -> bprintf buf "`List (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | `Option (loc, type_expr, annot_list) -> bprintf buf "`Option (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | `Nullable (loc, type_expr, annot_list) -> bprintf buf "`Nullable (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | `Shared (loc, type_expr, annot_list) -> bprintf buf "`Shared (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | `Wrap (loc, type_expr, annot_list) -> bprintf buf "`Wrap (%a, %a, %a)" print_loc loc print_type_expr type_expr print_annot_list annot_list | `Name (loc, type_inst, annot_list) -> bprintf buf "`Name (%a, %a, %a)" print_loc loc print_type_inst type_inst print_annot_list annot_list | `Tvar (loc, string) -> bprintf buf "`Tvar (%a, %S)" print_loc loc string and print_cell buf (loc, x, a) = bprintf buf "(%a, %a, %a)" print_loc loc print_type_expr x print_annot_list a and print_variant buf x = match x with `Variant (loc, (s, a), o) -> bprintf buf "`Variant (%a, (%S, %a), %a)" print_loc loc s print_annot_list a (print_opt print_type_expr) o | `Inherit (loc, x) -> bprintf buf "`Inherit (%a, %a)" print_loc loc print_type_expr x and print_field buf x = match x with `Field (loc, (s, kind, a), x) -> bprintf buf "`Field (%a, (%S, %a, %a), %a)" print_loc loc s print_field_kind kind print_annot_list a print_type_expr x | `Inherit (loc, x) -> bprintf buf "`Inherit (%a, %a)" print_loc loc print_type_expr x and print_field_kind buf fk = Buffer.add_string buf (match fk with `Required -> "`Required" | `Optional -> "`Optional" | `With_default -> "`With_default") and print_type_inst buf (loc, s, l) = bprintf buf "(%a, %S, %a)" print_loc loc s (print_list print_type_expr) l let print_module_item buf (`Type (loc, (name, param, a), x)) = bprintf buf "`Type (%a, (%S, %a, %a), %a)" print_loc loc name (print_list print_qstring) param print_annot_list a print_type_expr x let print_module_body buf l = bprintf buf "[\n"; List.iter (fun x -> print_module_item buf x; bprintf buf ";\n" ) l; bprintf buf "]\n" let print_module_body_def buf name l = bprintf buf "\ let %s_body : Atd_ast.module_body = let loc = Atd_ast.dummy_loc in %a let %s = %s_body (* for backward compatibility with atd <= 1.0.1 *) " name print_module_body l name name let print_module_head_def buf name an = bprintf buf "\ let %s_head : Atd_ast.module_head = let loc = Atd_ast.dummy_loc in (loc, %a) " name print_annot_list an let print_full_module_def buf name ((loc, an), l) = print_module_head_def buf name an; print_module_body_def buf name l; bprintf buf "\ let %s_full : Atd_ast.full_module = (%s_head, %s_body) " name name name atd-1.1.1/atd_reflect.mli000066400000000000000000000004651226670523100152520ustar00rootroot00000000000000 (** Conversion of an AST value into OCaml source code that creates this value *) val print_full_module_def : Buffer.t -> string -> Atd_ast.full_module -> unit (** [print_full_module_def buf name x] prints OCaml source code that would construct the given ATD tree [x] and call it [name]. *) atd-1.1.1/atd_tsort.ml000066400000000000000000000051031226670523100146220ustar00rootroot00000000000000 open Printf type ('a, 'b) node = ('a * 'a list * 'b) module type Ordered = sig type t val compare : t -> t -> int val to_string : t -> string end module Make (Param : Ordered) : sig val sort : (Param.t, 'a) node list -> (bool * 'a list) list end = struct module S = Set.Make (Param) module M = Map.Make (Param) type state = White | Grey | Black let fst3 (x, _, _) = x let init_states l = List.fold_left (fun m x -> M.add (fst3 x) (ref White) m) M.empty l let get_state key states = try !(M.find key states) with Not_found -> invalid_arg (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) let set_state key state states = try M.find key states := state with Not_found -> invalid_arg (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) let merge (s1, l1, ll1) (s2, l2, ll2) = (S.union s1 s2, l1 @ l2, ll1 @ ll2) let map_of_list l = List.fold_left (fun m x -> M.add (fst3 x) x m) M.empty l let get_node key graph = try M.find key graph with Not_found -> invalid_arg (sprintf "Atd_tsort: undefined child node %s" (Param.to_string key)) let rec sort_root graph states (x : (_, _) node) = let key, children, value = x in match get_state key states with Black -> (S.empty, [], []) | Grey -> (S.singleton key, [], []) | White -> set_state key Grey states; let closing_nodes, cycle_nodes, sorted = sort_list graph states children in set_state key Black states; if S.is_empty closing_nodes then (closing_nodes, [], (false, [value]) :: sorted) else let closing_nodes = S.remove key closing_nodes in let cycle_nodes = value :: cycle_nodes in if S.is_empty closing_nodes then (closing_nodes, [], (true, cycle_nodes) :: sorted) else (closing_nodes, cycle_nodes, sorted) and sort_list graph states l = List.fold_left ( fun accu key -> merge (sort_root graph states (get_node key graph)) accu ) (S.empty, [], []) l and sort (l : (Param.t, 'a) node list) = let graph = map_of_list l in let states = init_states l in let _, _, sorted = sort_list graph states (List.map fst3 l) in sorted end (* Testing *) (* module Test = Make (String) let test_result = Test.sort [ "1", [ "2"; "3" ], "1"; "2", [ "3" ], "2"; "3", [ "3"; "4" ], "3"; "4", [ "3"; ], "4"; "5", [ "6" ], "5"; "6", [ "6"; "1" ], "6"; ] *) atd-1.1.1/atd_tsort.mli000066400000000000000000000007521226670523100150000ustar00rootroot00000000000000 (* Generic topological sorting and cycle detection. This is useful for detecting which definitions are truly recursive, if allowed at all. *) type ('a, 'b) node = ('a * 'a list * 'b) module type Ordered = sig type t val compare : t -> t -> int val to_string : t -> string (* for error messages *) end module Make (Param : Ordered) : sig val sort : (Param.t, 'a) node list -> (bool * 'a list) list (* bool indicates whether definitions are mutually recursive. *) end atd-1.1.1/atd_util.ml000066400000000000000000000043131226670523100144260ustar00rootroot00000000000000 let read_lexbuf ?(expand = false) ?keep_poly ?(xdebug = false) ?(inherit_fields = false) ?(inherit_variants = false) ?(pos_fname = "") ?(pos_lnum = 1) lexbuf = Atd_lexer.init_fname lexbuf pos_fname pos_lnum; let head, body = Atd_parser.full_module Atd_lexer.token lexbuf in Atd_check.check body; let body = if inherit_fields || inherit_variants then Atd_inherit.expand_module_body ~inherit_fields ~inherit_variants body else body in let (body, original_types) = if expand then Atd_expand.expand_module_body ?keep_poly ~debug: xdebug body else (body, Hashtbl.create 0) in ((head, body), original_types) let read_channel ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ic = let lexbuf = Lexing.from_channel ic in let pos_fname = if pos_fname = None && ic == stdin then Some "" else pos_fname in read_lexbuf ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf let load_file ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum file = let ic = open_in file in let finally () = close_in_noerr ic in try let pos_fname = match pos_fname with None -> Some file | Some _ -> pos_fname in let ast = read_channel ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum ic in finally (); ast with e -> finally (); raise e let load_string ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum s = let lexbuf = Lexing.from_string s in read_lexbuf ?expand ?keep_poly ?xdebug ?inherit_fields ?inherit_variants ?pos_fname ?pos_lnum lexbuf module Tsort = Atd_tsort.Make ( struct type t = string let compare = String.compare let to_string s = s end ) let tsort l0 = let ignorable = [ "unit"; "bool"; "int"; "float"; "string"; "abstract" ] in let l = List.map ( fun def -> let `Type (loc, (name, _, _), x) = def in let deps = Atd_ast.extract_type_names ~ignorable x in (name, deps, def) ) l0 in List.rev (Tsort.sort l) atd-1.1.1/atd_util.mli000066400000000000000000000070361226670523100146040ustar00rootroot00000000000000 (** Top-level utilities *) val read_lexbuf : ?expand:bool -> ?keep_poly:bool -> ?xdebug:bool -> ?inherit_fields:bool -> ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> Lexing.lexbuf -> Atd_ast.full_module * Atd_expand.original_types (** Read an ATD file from a lexbuf. See also [read_channel], [load_file] and [load_string]. If expand is true, the second part of the return value will contain a hash table mapping the types generated during monomorphization back to their original polymorphic types. See {!Atd_expand.original_types} for more information about this table. If expand is false, the value will be the empty hash table. @param expand Perform monomorphization by creating specialized type definitions starting with an underscore. Default is false. See also {!Atd_expand}. This corresponds to the [-x] option of [atdcat]. @param keep_poly Preserve left-hand-side of all original type definitions instead of removing parametrized definitions. This option only applies when [expand = true]. Default is false. See also {!Atd_expand}. This corresponds to the [-xk] option of [atdcat]. @param xdebug Debugging option producing meaningful but non ATD-compliant type names when new types names are created. Default is false. This corresponds to the [-xd] option of [atdcat]. @param inherit_fields Expand [inherit] statements in record types. Default is false. See also {!Atd_inherit}. This corresponds to the [-if] option of [atdcat]. @param inherit_variants Expand [inherit] statements in sum types. Default is false. See also {!Atd_inherit}. This corresponds to the [-iv] option of [atdcat]. @param pos_fname Set the file name for use in error messages. Default is [""]. @param pos_lnum Set the number of the first line for use in error messages. Default is [1]. *) val read_channel : ?expand:bool -> ?keep_poly:bool -> ?xdebug:bool -> ?inherit_fields:bool -> ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> in_channel -> Atd_ast.full_module * Atd_expand.original_types (** Read an ATD file from an [in_channel]. Options: see [read_lexbuf]. The default [pos_fname] is set to [""] when appropriate. *) val load_file : ?expand:bool -> ?keep_poly:bool -> ?xdebug:bool -> ?inherit_fields:bool -> ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> string -> Atd_ast.full_module * Atd_expand.original_types (** Read an ATD file. Options: see [read_lexbuf]. The default [pos_fname] is the given input file name. *) val load_string : ?expand:bool -> ?keep_poly:bool -> ?xdebug:bool -> ?inherit_fields:bool -> ?inherit_variants:bool -> ?pos_fname:string -> ?pos_lnum:int -> string -> Atd_ast.full_module * Atd_expand.original_types (** Read ATD data from a string. Options: see [read_lexbuf]. *) val tsort : Atd_ast.module_body -> (bool * Atd_ast.module_body) list (** Topological sort for dependency analysis. [tsort] splits definitions into mutually-recursive groups, ordered such that each group may only depend on type definitions of its own group or previous groups. The boolean flags indicate groups of one or more mutually recursive definitions. *) atd-1.1.1/atdcat.ml000066400000000000000000000113351226670523100140630ustar00rootroot00000000000000 open Printf let html_of_doc loc s = let doc = Atd_doc.parse_text loc s in Atd_doc.html_of_doc doc let format_html_comments ((section, (loc, l)) as x) = match section with "doc" -> (try match List.assoc "html" l with (loc, Some s) -> let comment = "(*html " ^ s ^ "*)" in Easy_format.Atom (comment, Easy_format.atom) | _ -> raise Not_found with Not_found -> match List.assoc "text" l with (loc, Some s) -> let comment = "(*html " ^ html_of_doc loc s ^ "*)" in Easy_format.Atom (comment, Easy_format.atom) | _ -> Atd_print.default_annot x ) | _ -> Atd_print.default_annot x let print_atd ~html_doc ast = let annot = if html_doc then Some format_html_comments else None in let pp = Atd_print.format ?annot ast in Easy_format.Pretty.to_channel stdout pp; print_newline () let print_ml ~name ast = let buf = Buffer.create 1000 in Atd_reflect.print_full_module_def buf name ast; print_string (Buffer.contents buf); print_newline () let strip all sections x = let filter = if all then fun l -> [] else List.filter (fun (name, fields) -> not (List.mem name sections)) in Atd_ast.map_all_annot filter x let parse ~expand ~keep_poly ~xdebug ~inherit_fields ~inherit_variants ~strip_all ~strip_sections files = let l = List.map ( fun file -> fst ( Atd_util.load_file ~expand ~keep_poly ~xdebug ~inherit_fields ~inherit_variants file ) ) files in let heads, bodies = List.split l in let first_head = (* heads in other files than the first one are tolerated but ignored *) match heads with x :: l -> x | [] -> (Atd_ast.dummy_loc, []) in let m = first_head, List.flatten bodies in strip strip_all strip_sections m let print ~html_doc ~out_format ast = let f = match out_format with `Atd -> print_atd ~html_doc | `Ocaml name -> print_ml ~name in f ast let split_on_comma = Str.split_delim (Str.regexp ",") let () = let expand = ref false in let keep_poly = ref false in let xdebug = ref false in let inherit_fields = ref false in let inherit_variants = ref false in let strip_sections = ref [] in let strip_all = ref false in let out_format = ref `Atd in let html_doc = ref false in let files = ref [] in let options = [ "-x", Arg.Set expand, " make type expressions monomorphic"; "-xk", Arg.Unit (fun () -> expand := true; keep_poly := true), " keep parametrized type definitions and imply -x. Default is to return only monomorphic type definitions"; "-xd", Arg.Unit (fun () -> expand := true; xdebug := true), " debug mode implying -x"; "-i", Arg.Unit (fun () -> inherit_fields := true; inherit_variants := true), " expand all `inherit' statements"; "-if", Arg.Set inherit_fields, " expand `inherit' statements in records"; "-iv", Arg.Set inherit_variants, " expand `inherit' statements in sum types"; "-ml", Arg.String (fun s -> out_format := `Ocaml s), " output the ocaml code of the ATD abstract syntax tree"; "-html-doc", Arg.Set html_doc, " replace directly by (*html ... *) or replace by (*html ... *) where the contents are formatted as HTML using

, and 

.
          This is suitable input for \"caml2html -ext html:cat\"
          which converts ATD files into HTML.";

    "-strip",
    Arg.String (fun s -> strip_sections := split_on_comma s @ !strip_sections),
    "NAME1[,NAME2,...]
          remove all annotations of the form ,
          , etc.";

    "-strip-all", Arg.Set strip_all,
    "
          remove all annotations";

    "-version",
    Arg.Unit (fun () ->
                print_endline Atd_version.version;
                exit 0),
    "
          print the version of atd and exit";
  ]
  in
  let msg = sprintf "Usage: %s FILE" Sys.argv.(0) in
  Arg.parse options (fun file -> files := file :: !files) msg;
  try
    let ast =
      parse
          ~expand: !expand
          ~keep_poly: !keep_poly
          ~xdebug: !xdebug
          ~inherit_fields: !inherit_fields
          ~inherit_variants: !inherit_variants
          ~strip_all: !strip_all
          ~strip_sections: !strip_sections
          !files
    in
    print ~html_doc: !html_doc ~out_format: !out_format ast
  with
      Atd_ast.Atd_error s ->
        flush stdout;
        eprintf "%s\n%!" s
    | e -> raise e
atd-1.1.1/manual/000077500000000000000000000000001226670523100135435ustar00rootroot00000000000000atd-1.1.1/manual/Makefile000066400000000000000000000017401226670523100152050ustar00rootroot00000000000000# `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-manual atd-body

.PHONY: all pdf txt html clean

all: pdf txt html
pdf: atd-manual.pdf
txt: atd-manual.txt
html: atd-manual.html

atd-manual.tex: ../atd_version.ml atd-manual.mlx
	OCAMLPATH=../..:$$OCAMLPATH camlmix atd-manual.mlx -o atd-manual.tex

atd-body.tex: ../atd_version.ml macros.ml atd-body.mlx
	OCAMLPATH=../..:$$OCAMLPATH camlmix atd-body.mlx -o atd-body.tex

atd-manual.txt: $(addsuffix .tex, $(TEXFILES))
	rm -f *.aux
	hevea -fix -text atd-manual
	iconv -f ISO_8859-1 -t UTF-8 < atd-manual.txt > ../atd-manual.txt

atd-manual.html: $(addsuffix .tex, $(TEXFILES))
	rm -f *.aux
	hevea -fix atd-manual

atd-manual.pdf: $(addsuffix .tex, $(TEXFILES))
	pdflatex atd-manual
	pdflatex atd-manual

clean:
	rm -f *.aux *.toc *.log *.out *.haux *.htoc *.fls *.mlx.ml \
		atd-manual.pdf atd-manual.txt atd-manual.html
atd-1.1.1/manual/atd-body.mlx000066400000000000000000000401361226670523100157740ustar00rootroot00000000000000% -*- latex -*-

##
#use "topfind";;
#require "caml2html";;
#require "easy-format";;
#directory "..";;
#load "atd.cma";;
#require "unix";;
#use "../atd_version.ml";;
#use "macros.ml";;
##

\section{Introduction}

ATD stands for Adjustable Type Definitions.

## atd () ##
(* This is a sample ATD file *)

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;
}
## () ##

ATD is a language for defining data types across multiple programming
languages and multiple data formats.
That's it.

We provide an OCaml library that provides a parser and a collection of
tools that make it easy to write data validators and code generators
based on ATD definitions.

Unlike the big ``frameworks'' that provide ``everything'' in one
monolithic package, we split the problem of data exchange into logical
modules and ATD is one of them.
In particular, we acknowledge that the following pieces have
little in common and should be defined and implemented separately:

\begin{itemize}
\item data type specifications
\item transport protocols
\item serialization formats
\end{itemize}

Ideally we want just one single language for defining data types and
it should accomodate all programming languages and data formats. ATD
can play this role, but its OCaml implementation makes it
particularly easy to translate ATD specifications into other interface
definition languages if needed.

It is however much harder to imagine that a single transport protocol and
a single serialization format would ever become the only ones used.
A reader from the future might wonder why we are even considering
defining a transport protocol and a serialization format together.
This has been a widespread practice at least until the beginning of
the 21st century (ONC RPC, ICE, Thrift, etc.). For mysterious reasons,
people somehow became convinced that calls to remote services should
be made to mimic internal function calls, pretending that nothing
really bad could happen on the way between the caller and the remote
service. Well, I don't let my 3-old daughter go to school by herself
because the definition of the external world is precisely that it is
unsafe.

Data input is by definition unsafe. A program whose internal data is
corrupted should abort but a failed attempt to read external data
should not cause a program to abort. On the contrary, a program should
be very resistent to all forms of data corruption and attacks and
provide the best diagnosis possible when problems with external data
occur.

Because data exchange is critical and involves multiple partners, we
depart from magic programming language-centric or company-centric
approaches. We define ATD, a data type definition language
designed for maximum expressivity, compatibility across languages and
static type checking of programs using such data.


\subsection{Scope}


ATD offers a core syntax for type definitions, i.e. an idealized view
of the structure of data. Types are mapped to each programming
language or data format using language-specific conventions.
Annotations can complete the type definitions in
order to specify options for a particular language.
Annotations are placed in angle brackets after the element they refer to:

## atd () ##
type profile = {
  id : int ;
    (*
       An int here will map to an OCaml int64 instead of
       OCaml's default int type.
       Other languages than OCaml will use their default int type.
    *)

  age : int;
    (* No annotation here, the default int type will be used. *)
}
## () ##

ATD supports:
\begin{itemize}
\item the following atomic types: bool, int, float, string and unit;
\item built-in list and option types;
\item records aka structs with a syntax for optional fields with or
  with default;
\item tuples;
\item sum types aka variant types, algebraic data types or tagged unions;
\item parametrized types;
\item inheritance for both records and sum types;
\item abstract types;
\item arbitrary annotations.
\end{itemize}

ATD by design does not support:
\begin{itemize}
\item function types, function signatures or method signatures;
\item a syntax to represent values;
\item a syntax for submodules.
\end{itemize}


\subsection{Language overview}

ATD was strongly inspired by the type system of ML and OCaml. Such a
type system allows static type checking and type inference, properties
which contribute to the safety and conciseness of the language.

Unlike mainstream languages like Java, C++, C\# or Python to name a
few, languages such as Haskell or OCaml offer sum types,
also known as algebraic data types or variant types. These allow to
specify that an object is of one kind or another without ever
performing dynamic casts.

## atd () ##
(* Example of a sum type in ATD. The vertical bar reads `or'. *)
type shape = [
    Square of float               (* argument: side length *)
  | Rectangle of (float * float)  (* argument: width and height *)
  | Circle of float               (* argument: radius *)
  | Dot                           (* no argument *)
]
## () ##

A notable example of sum types is the predefined option type.
An object of an option type contains either one value of a given type
or nothing. We could define our own {\tt int\_option} type as follows:

## atd () ##
type int_option = [ None | Some of int ]
## () ##

ATD supports parametrized types also known as generics in Java or
templates in C++.  We could define our own generic option type as
follows:

## atd () ##
type 'a opt = [ None | Some of 'a ]
  (* 'a denotes a type parameter. *)

type opt_int = int opt
  (* equivalent to int_option defined in the previous example *)

type opt_string = string opt
  (* same with string instead of int *)
## () ##

In practice we shall use the predefined option type.
The option type is fundamentally different from nullable objects since
the latter don't allow values that would have type {\tt 'a option option}.

ATD also support product types. They come in two forms: tuples and
records:

## atd () ##
type tuple_example = (string * int)

type record_example = {
  name : string;
  age : int;
}
## () ##

Although tuples in theory are not more expressive than
records, they are much more concise and languages that support them
natively usually do not require type definitions.

Finally, ATD supports multiple inheritance which is a simple mechanism
for adding fields to records or variants to sum types:

## atd () ##
type builtin_color = [
    Red | Green | Blue | Yellow
  | Purple | Black | White
]

type rgb = (float * float * float)
type cmyk = (float * float * float * float)

(* Inheritance of variants *)
type color = [
    inherit builtin_color
  | Rgb of rgb
  | Cmyk of cmyk
]
## () ##

## atd () ##
type basic_profile = {
  id : string;
  name : string;
}

(* Inheritance of record fields *)
type full_profile = {
  inherit basic_profile;
  date_of_birth : (int * int * int) option;
  street_address1 : string option;
  street_address2 : string option;
  city : string option;
  zip_code : string option;
  state : string option;
}
## () ##


\subsection{Editing and validating ATD files}

The extension for ATD files is {\tt .atd}. Editing ATD files is best
achieved using an OCaml-friendly editor since the ATD syntax is vastly
compatible with OCaml and uses a subset of OCaml's keywords.

Emacs users can use caml-mode or tuareg-mode to edit ATD files.
Adding the following line to the {\tt \~{}/.emacs} file will
automatically use tuareg-mode when opening a file with a {\tt .atd}
extension:
\begin{verbatim}
(add-to-list 'auto-mode-alist '("\\.atd\\'" . tuareg-mode))
\end{verbatim}

The syntax of an ATD file can be checked with the program
{\tt atdcat} provided with the OCaml library {\tt atd}.
{\tt atdcat} pretty-prints its input data, optionally after some
transformations such as monomorphization or inheritance.
Here is the output of {\tt atdcat -help}:
## shell "PATH=.. atdcat -help" ##


\section{ATD language}

\newcommand\str[1]{\textcolor{CstringColor}{\texttt{#1}}}
\newcommand\lval[1]{\hypertarget{#1}{#1}}
\newcommand\rval[1]{\hyperlink{#1}{#1}}
\newcommand\com[1]{\textit{#1}}

This is a precise description of the syntax of the ATD language, not a
tutorial.

\subsection{Notations}

Lexical and grammatical rules are expressed using a BNF-like syntax.
Graphical terminal symbols use \str{unquoted strings in typewriter font}.
Non-graphical characters use their official uppercase ASCII name such
as LF for the newline character or SPACE for the space character.
Non-terminal symbols use the regular font and link to their
definition.  Parentheses are used for grouping.

The following postfix operators are used to specify repeats:

\begin{tabular}{ll}
x* & 0, 1 or more occurrences of x \\
x? & 0 or 1 occurrence of x \\
x+ & 1 or more occurrences of x \\
\end{tabular}


\subsection{Lexical rules}

ATD does not enforce a particular character encoding other than ASCII
compatibility.  Non-ASCII text and data found in annotations and
in comments may contain arbitrary bytes in the non-ASCII range 128-255
without escaping.  The UTF-8 encoding is however strongly recommended
for all text.  The use of hexadecimal or decimal escape sequences is
recommended for binary data.

An ATD lexer splits its input into a stream of \rval{token}s,
discarding white\rval{space} and \rval{comment}s.

\begin{tabular}{rcll}
\lval{token} & ::= & \rval{keyword}
                   | \rval{lident}
                   | \rval{uident}
                   | \rval{tident}
                   | \rval{string} & \\
\lval{ignorable} & ::= & \rval{space} | \rval{comment}
                       & \com{discarded} \\
\lval{space} & ::= & SPACE | TAB | CR | LF & \\
\lval{blank} & ::= & SPACE | TAB & \\
\lval{comment} & ::= & \str{(*} (\rval{comment} | \rval{string} | byte)*
                       \str{*)} & \\
\lval{lident} & ::= & (\rval{lower} 
                    | \str{\_} \rval{identchar}) \rval{identchar}*
                    & \com{lowercase identifier} \\
\lval{uident} & ::= & \rval{upper} \rval{identchar}*
                    & \com{uppercase identifier} \\
\lval{tident} & ::= & \str{'} \rval{lident} & \com{type parameter} \\
\lval{lower} & ::= & \str{a}...\str{z} & \\
\lval{upper} & ::= & \str{A}...\str{Z} & \\
\lval{identchar} & ::= & \rval{upper} | \rval{lower} | \rval{digit}
                       | \str{\_} | \str{'}& \\
\lval{string} & ::= & \str{"} \rval{substring}* \str{"}
                    & \com{string literal, used in annotations} \\
\lval{substring} & ::= & \str{$\backslash\backslash$}
                       & \com{single backslash} \\
                 &  |  & \str{$\backslash$"}
                       & \com{double quote} \\
                 &  |  & \str{$\backslash$x} \rval{hex} \rval{hex}
                       & \com{single byte in hexadecimal notation} \\
                 &  |  & \str{$\backslash$}
                           \rval{digit} \rval{digit} \rval{digit}
                       & \com{single byte in decimal notation} \\
                 &  |  & \str{$\backslash$n} & \com{LF} \\
                 &  |  & \str{$\backslash$r} & \com{CR} \\
                 &  |  & \str{$\backslash$t} & \com{TAB} \\
                 &  |  & \str{$\backslash$b} & \com{BS} \\
                 &  |  & \str{$\backslash$} CR? LF blank* & \com{discarded} \\
                 &  |  & not-backslash
                 & \com{any byte except \str{$\backslash$} or \str{"}} \\
\lval{digit} & ::= & \str{0}...\str{9} & \\
\lval{hex} & ::= & \str{0}...\str{9} | \str{a}...\str{f} |
                   \str{A}...\str{F} & \\
\lval{keyword} & ::= & \str{(} | \str{)} | \str{[}
                       | \str{]} | \str{\{} | \str{\}}
                       | \str{<} | \str{>} & \\
               &     & | \str{;} | \str{,} | \str{:} | \str{*}
                       | \str{|} | \str{=} | \str{?} | \str{\~{}} & \\
               &     & | \str{type} | \str{of} | \str{inherit}
                     & \com{all keywords} \\
\end{tabular}


\subsection{Grammar}


\begin{tabular}{rcll}
\lval{module} & ::= & \rval{annot}* \rval{typedef}* & \com{entry point} \\

\lval{annot} & ::= & \str{<} \rval{lident} annot-field* \str{>}
                   & \com{annotation} \\

\lval{annot-field} & ::= & (\rval{lident} (\str{=} \rval{string})?) & \\

\lval{typedef} & ::= & \str{type} \rval{params}? lident annot
                       \str{=} \rval{expr}
                     & \com{type definition} \\

\lval{params} & ::= & \rval{tident} & one parameter \\
              &  |  & \str{(} \rval{tident} (\str{,} \rval{tident})+ \str{)}
                    & \com{two or more parameters} \\

\lval{expr} & ::= & \rval{expr-body} \rval{annot}* & \com{type expression} \\
            &  |  & \rval{tident} & \\

\lval{expr-body} & ::= & \rval{args}? \rval{lident} & \\
                 &  |  & \str{(}
                           (\rval{cell} (\str{*} \rval{cell})*)?
                         \str{)} & \com{tuple type} \\
                 &  |  & \str{\{}
                           ((\rval{field} (\str{;} \rval{field})*) \str{;}?)?
                         \str{\}} & \com{record type} \\
                 &  |  & \str{[}
                           (\str{|}? \rval{variant} (\str{|} \rval{variant})*)?
                         \str{]} & \com{sum type} \\
\lval{args} & ::= & \rval{expr} & \com{one argument} \\
            &  |  & \str{(} \rval{expr} (\str{,} \rval{expr})+ \str{)}
                  & \com{two or more arguments} \\

\lval{cell} & ::= & (\rval{annot}+ \str{:})? \rval{expr} & \\

\lval{field} & ::= & (\str{?} | \str{\~{}})? \rval{lident}
                     \str{=} \rval{expr} & \\
             &  |  & \str{inherit} \rval{expr} & \\

\lval{variant} & ::= & \rval{uident} \rval{annot}* \str{of} \rval{expr} & \\
               &  |  & \rval{uident} \rval{annot}* & \\
               &  |  & \str{inherit} \rval{expr} & \\
\end{tabular}



\subsection{Predefined type names}

The following types are considered predefined and may not be
redefined.

\begin{tabular}{ll}
Type name & Intended use \\
\hline
\tt unit & Type of just one value, useful with parametrized types \\
\tt bool & Boolean \\
\tt int & Integer \\
\tt float & Floating-point number \\
\tt string & Sequence of bytes or characters \\
\tt 'a option & Zero or one element \\
\tt 'a list & Collection or sequence of elements \\
\tt 'a shared & Values for which sharing must be preserved \\
\tt abstract & Type defined elsewhere \\
\end{tabular}


\subsection{Shared values}

ATD supports a special type $x$ \texttt{shared} where $x$ can be 
any monomorphic type expression.
It allows notably to represent cyclic values and to enforce that cycles
are preserved during transformations such as serialization.

## atd () ##
(* Example of a simple graph type *)
type shared_node = node shared (* sharing point *)
type graph = shared_node list
type node = {
  label : string;
  neighbors : shared_node list;
}
## () ##

Two shared values that are physically identical must remain physically
identical after any translation from one data format to another.

Each occurrence of a \texttt{shared} type expression in the ATD
source definition defines its own sharing point.
Therefore the following attempt at defining a graph type will not
preserve cycles because two sharing points are defined:

## atd () ##
(* Incorrect definition of a graph type *)
type node = {
  label : string;
  neighbors : node shared (* sharing point 1 *) list;
}

(* Second occurrence of "shared", won't preserve cycles! *)
type graph = node shared (* sharing point 2 *) list
## () ##

There is actually a way of having multiple \texttt{shared}
type expressions using the same sharing point
but this feature is designed for code generators and
should not be used in handwritten ATD definitions.
The technique consists in providing an annotation of the form
\texttt{} where $x$ is any string identifying the sharing
point.
The graph example can be rewritten correctly as:

## atd () ##
type node = {
  label : string;
  neighbors : node shared  list;
}

type graph = node shared  list
## () ##



\section{OCaml \texttt{atd} library}

The documentation for the \texttt{atd} library is available in HTML
form at \url{##= odoc_url ##}.
atd-1.1.1/manual/atd-manual.mlx000066400000000000000000000153511226670523100163150ustar00rootroot00000000000000% -*- latex -*-
##
#use "../atd_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{ATD\\
\textsc{Adjustable Type Definitions}\\
release ##= version ##}
\author{Martin Jambon\\
$\copyright$ 2010 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}


\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}}

% not supported by hevea
%\usepackage{amsthm}
%\newtheorem{definition}{Definition}

\begin{document}
\maketitle
\tableofcontents
\include{atd-body}
\end{document}
atd-1.1.1/manual/macros.ml000066400000000000000000000025421226670523100153640ustar00rootroot00000000000000let 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 ocaml () =
  Camlmix.print_with print_ocaml

let atd () =
  Camlmix.print_with print_atd



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 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 odoc_url = 
  "http://oss.wink.com/atd/atd-" ^ version ^ "/odoc/index.html"
atd-1.1.1/release.sh000077500000000000000000000014031226670523100142430ustar00rootroot00000000000000#! /bin/sh -e

tmp=/tmp/atd-$(date +%s)
mkdir $tmp
cd $tmp
git clone git@github.com:MyLifeLabs/atd.git
cd atd
make VERSION
version=$(cat VERSION)
make doc
rm -rf release/atd-$version
mkdir -p release/atd-$version
mkdir -p release/atd-$version/odoc
mkdir -p release/atd-$version/manual
find `git ls-files | grep -v manual` | cpio -pvd release/atd-$version
cd manual
find `git ls-files` | cpio -pvd ../release/atd-$version/manual
cp atd-manual.pdf ../release/atd-$version/manual
cp atd-manual.txt ../release/atd-$version/manual
cp atd-manual.html ../release/atd-$version/manual
cd ..
find odoc/* | cpio -pvd release/atd-$version
cd release && tar czf atd-$version.tar.gz atd-$version
echo "Release files:
$tmp/atd/release/atd-$version
$tmp/atd/release/atd-$version.tar.gz"
atd-1.1.1/test.atd000066400000000000000000000044221226670523100137410ustar00rootroot00000000000000(* -*- tuareg -*- *)



type x  = y 
type y  = x   (* conflict or inheritance or anything: unspecified. *)


type ('a, 'b, 'c) yyy
  
  
   =
    int

type z =
    [
    | X
    | Y of x
    | Z  of z ]

type ('a, 'b, 'c) tiptoptiptop  =
    [ Foo 
    | Fioo  of int
    | Bar  of z
    | Aaaaaaaaaaaaa ]
      

type kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk = int option

type ('a, 'b, 'ccccccccccccccccccccc) r = {
  x :int;
  y:float option;
  adfadfafa
    
    
    :
    (int list option,'ccccccccccccccccccccc,'ccccccccccccccccccccc)
    tiptoptiptop;
  llllllllllllllllllllllllll: kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk;
  ?z : int option;
  ~t : int;
}

type tuple = (z * z * tuple option * kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk
              * z * z * tuple option * kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk)


type tuple2 = (int * float)

type singleton = (int)
type zero_tuple = ()

type 'a i1 =
    [ inherit 'a j2
    | I1 ]

type 'a i2 =
    [ inherit z
    | I2 of 'a ]

type i = int i1

type 'b j2 = 'b i2

type i3 = [ inherit i | I1 of float | Y ]


type r1 = { x1 : int }
type r2 = { inherit r1; x2 : int }

type nullable_string = string nullable

type pair =
    (  : int *  : bool)

type 'a abs = abstract
type int_abs = int abs

type 'a l = 'a list
type 'a int_l = int l
type int_list = int list 
type int_array = int list 

type 'a recur = { cyc : 'a recur option }

type 'a ta = [ Ta of 'a ] 
type int_ta = int ta 
type int_ta2 = int ta  

type timestamp = string wrap 
atd-1.1.1/test2.atd000066400000000000000000000015411226670523100140220ustar00rootroot00000000000000type z = abstract list

type 'a t = int
type x = float t

type 'a l = [ Nil | Cons of ('a * 'a l) ]

type int_l = int l
type float_l = float l
type tup = (int l * float_l)

type ('a, 'b) tbl = ('a * 'b) list list
type 'a string_tbl = (string, 'a) tbl
type string_bool_tbl = bool string_tbl

type 'a b = 'a a
type 'a a = 'a b
type c = c a b a


type 'id gen_profile = {
  id : 'id;
  name : string option;
  age : int option
}

type basic_profile = int gen_profile

type profile_enhancements = {
  credit_card_number : string
}

type ('id, 'self) nested_profile = {
  inherit 'id gen_profile;
  sub_profiles : 'self list
}

type profile = {
  inherit (int, profile) nested_profile;
  inherit profile_enhancements
}
(* expands to:

type profile = {
  id: int;
  name: string option;
  age: int option;
  sub_profiles: profile list;
  credit_card_number: string
}

*)