diff -Nru type-conv-111.13.00/CHANGES.md type-conv-113.00.02/CHANGES.md --- type-conv-111.13.00/CHANGES.md 1970-01-01 00:00:00.000000000 +0000 +++ type-conv-113.00.02/CHANGES.md 2015-09-24 18:04:37.000000000 +0000 @@ -0,0 +1,186 @@ +## 112.01.00 + +- Updated ast matching for 4.02 + +## 111.13.00 + +- Removed some unused-value warnings when `with` is used in signatures. + + Removed warnings in cases like: + + include (module_expr : sig type t with bin_io end) + +## 109.60.00 + +- Compatibility with warning 7 (method override) + +## 109.53.00 + +Bump version number + +## 109.52.00 + +- Removed comments from pretty-printed types in `type_conv` error + messages. + +## 109.47.00 + +- Made `type nonrec` work when a type has both an equation and a representation. + + For example: + + ```ocaml + type t = A of t + module T = struct + type nonrec t = t = A of t + end + ``` + +## 109.41.00 + +- Fixed the generated code of `typerep` and `sexplib` on sum types containing `True` or `False`. + + Without this fix, `typerep` would wrong constructor names for + `Blang.t`, for instance. + + `Variantslib` has the same problem but applying the same fix there + would still not make the generated code compile because the generated + code would contain labels and variable named `true` or `false`. + + Other syntax extensions should not be affected because they don't + build strings from constructor names. + +## 109.28.00 + +- Fixed an issue with `type_conv` in the toplevel. + + Used AST filters for the `_no_unused_value_warning_` machinery. + `type_conv` modifies the parser but it didn't work well in the + toplevel. + + Removed the `parsing_mli` reference, an instead always add the + special `_no_unused_value_warning_` type and just strip it for + signature items. + +## 109.20.00 + +- Removed some warnings caused by generated signatures. + + 1. In signatures on local modules. + 2. When there are duplicate signature items like in this example: + + ```ocaml + module Warnings : sig + type t = private { foo : int } with fields (** used to say unused value foo *) + val foo : string + end = struct + type t = { foo : int } with fields + let foo = "a" + end + ``` + + 3. In the signatures of all the parameters of functors that take multiple + parameters; this used to work only for the last parameter. + +## 109.08.00 + +- Fixed type_conv to stop dropping parens in arguments such as: + + type t = { + a : int with default(1), sexp_drop_if(fun x -> (x + 1) * 2 = 4) + } with sexp + +## 2012-07-15 + +- Added support for record field annotations and defaults. +- Fixes for upcoming OCaml 4.00 release. + +## 2011-09-15 + +- Fixes to improve package dependency resolution. + +## 2011-08-02 + +- Added missing module type case for "module type of". + +## 2011-07-04 + +- Merged with Jane Street version. API changes: + + Removed functions: + + * Gen.ide + * Gen.idp + + Removed location arguments from: + + * type_is_recursive + * drop_variance_annotations + +## 2010-12-22 + +- Merged with Jane Street version. No code changes. + +## 2010-09-25 + +- Added a missing type case to type_is_recursive. Thanks to Michael + Wawrzoniak for this patch! + +## 2010-07-07 + +- Major changes for compatibility with OCaml 3.12. + +## 2010-06-03 + +- Improved determination of type_conv paths. Thanks to Jacques Le + Normand for this patch! + +## 2009-09-19 + +- Added missing type cases for supporting variant types. + +## 2009-01-14 + +- Added support for type converters that take arguments. Thanks to + Jérémie Dimino for this patch! + + Added support for deprecated OCaml syntax, since the compiler still + supports it, too. + +## 2008-10-22 + +- Fixed bug preprocessing labeled arguments in function types. + +## 2008-10-18 + +- Fix for upcoming OCaml release 3.11. + +## 2008-10-07 + +- Added a patch to improve handling of type conversion paths. + + Thanks to David Rajchenbach-Teller for + the patch! + +## 2008-08-20 + +- Added support for exception converters. + +## 2008-07-25 + +- Fixed bug concerning variance annotations in type + definitions within structures. + +## 2008-03-17 + +- Improved META file and support of toplevel interpreter. + +## 2008-02-11 + +- Added support for handling variance annotations in signatures, and for + empty types. + +## 2007-10-14 + +- Initial release. + diff -Nru type-conv-111.13.00/CHANGES.txt type-conv-113.00.02/CHANGES.txt --- type-conv-111.13.00/CHANGES.txt 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/CHANGES.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -2012-07-15: Added support for record field annotations and defaults. - - Fixes for upcoming OCaml 4.00 release. - -2011-09-15: Fixes to improve package dependency resolution. - -2011-08-02: Added missing module type case for "module type of". - -2011-07-04: Merged with Jane Street version. API changes: - - Removed functions: - - * Gen.ide - * Gen.idp - - Removed location arguments from: - - * type_is_recursive - * drop_variance_annotations - -2010-12-22: Merged with Jane Street version. No code changes. - -2010-09-25: Added a missing type case to type_is_recursive. - Thanks to Michael Wawrzoniak for this - patch! - -2010-07-07: Major changes for compatibility with OCaml 3.12. - -2010-06-03: Improved determination of type_conv paths. - Thanks to Jacques Le Normand for this - patch! - -2009-09-19: Added missing type cases for supporting variant types. - -2009-01-14: Added support for type converters that take arguments. - Thanks to Jérémie Dimino for this - patch! - - Added support for deprecated OCaml syntax, since the compiler - still supports it, too. - -2008-10-22: Fixed bug preprocessing labeled arguments in function types. - -2008-10-18: Fix for upcoming OCaml release 3.11. - -2008-10-07: Added a patch to improve handling of type conversion paths. - - Thanks to David Rajchenbach-Teller - for the patch! - -2008-08-20: Added support for exception converters. - -2008-07-25: Fixed bug concerning variance annotations in type - definitions within structures. - -2008-03-17: Improved META file and support of toplevel interpreter. - -2008-02-11: Added support for handling variance annotations in - signatures, and for empty types. - -2007-10-14: Initial release. diff -Nru type-conv-111.13.00/COPYRIGHT.txt type-conv-113.00.02/COPYRIGHT.txt --- type-conv-111.13.00/COPYRIGHT.txt 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/COPYRIGHT.txt 2015-09-24 18:04:37.000000000 +0000 @@ -11,7 +11,7 @@ The following company has sponsored and has copyright in part of this work: - Jane Street Holding, LLC + Jane Street Group, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA diff -Nru type-conv-111.13.00/debian/changelog type-conv-113.00.02/debian/changelog --- type-conv-111.13.00/debian/changelog 2015-11-03 21:15:25.000000000 +0000 +++ type-conv-113.00.02/debian/changelog 2016-01-01 19:21:29.000000000 +0000 @@ -1,8 +1,9 @@ -type-conv (111.13.00-1build1) xenial; urgency=medium +type-conv (113.00.02-1) unstable; urgency=medium - * No-change rebuild against ocaml 4.02. + * New upstream release + * Bump Standards-Version - -- Łukasz 'sil2100' Zemczak Tue, 03 Nov 2015 15:15:25 -0600 + -- Hilko Bengen Fri, 01 Jan 2016 20:21:24 +0100 type-conv (111.13.00-1) unstable; urgency=medium diff -Nru type-conv-111.13.00/debian/control type-conv-113.00.02/debian/control --- type-conv-111.13.00/debian/control 2014-09-24 18:47:06.000000000 +0000 +++ type-conv-113.00.02/debian/control 2016-01-01 19:19:41.000000000 +0000 @@ -12,7 +12,7 @@ camlp4, camlp4-extra, dh-ocaml (>= 0.9) -Standards-Version: 3.9.5 +Standards-Version: 3.9.6 Vcs-Browser: http://anonscm.debian.org/gitweb/?p=pkg-ocaml-maint/packages/type-conv.git Vcs-Git: git://anonscm.debian.org/pkg-ocaml-maint/packages/type-conv.git Homepage: https://forge.ocamlcore.org/projects/type-conv diff -Nru type-conv-111.13.00/INSTALL.txt type-conv-113.00.02/INSTALL.txt --- type-conv-111.13.00/INSTALL.txt 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/INSTALL.txt 2015-09-24 18:04:37.000000000 +0000 @@ -1,5 +1,6 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: a332b0d0572a054e00f4c318f478af84) *) +(* DO NOT EDIT (digest: ec301781780831fd51696109455dd2c3) *) + This is the INSTALL file for the type_conv distribution. This package uses OASIS to generate its build system. See section OASIS for @@ -9,6 +10,7 @@ ============ In order to compile this package, you will need: + * ocaml (>= 4.00.0) * findlib (>= 1.3.2) diff -Nru type-conv-111.13.00/lib/META type-conv-113.00.02/lib/META --- type-conv-111.13.00/lib/META 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/lib/META 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 561e7333a5d1fc6eee9ae8bbbbe1d037) -version = "111.13.00" -description = "Syntax extension for type_conv" -requires = "camlp4" -archive(syntax, preprocessor) = "pa_type_conv.cma" -archive(syntax, toploop) = "pa_type_conv.cma" -archive(syntax, byte) = "pa_type_conv.cma" -archive(syntax, byte, plugin) = "pa_type_conv.cma" -archive(syntax, native) = "pa_type_conv.cmxa" -archive(syntax, native, plugin) = "pa_type_conv.cmxs" -exists_if = "pa_type_conv.cma" -# OASIS_STOP - diff -Nru type-conv-111.13.00/lib/pa_type_conv.ml type-conv-113.00.02/lib/pa_type_conv.ml --- type-conv-111.13.00/lib/pa_type_conv.ml 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/lib/pa_type_conv.ml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1110 +0,0 @@ -(* Pa_type_conv: Preprocessing Module for Registering Type Conversions *) - -open Printf - -open Camlp4 -open PreCast -open Ast - -(* Utility functions *) - -let get_loc_err loc msg = - sprintf "File \"%s\", line %d, characters %d-%d: %s" - (Loc.file_name loc) (Loc.start_line loc) - (Loc.start_off loc - Loc.start_bol loc) - (Loc.stop_off loc - Loc.stop_bol loc) - msg - -(* To be deleted once the OCaml team fixes Mantis issue #4751. - This function is copied from the compiler, function hash_variant - in typing/btype.ml. *) -let hash_variant s = - let accu = ref 0 in - for i = 0 to String.length s - 1 do - accu := 223 * !accu + Char.code s.[i] - done; - (* reduce to 31 bits *) - accu := !accu land (1 lsl 31 - 1); - (* make it signed for 64 bits architectures *) - if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu - -let () = assert (Obj.magic `Latency_stats = hash_variant "Latency_stats") - -(* Module/File path management *) - -type path = - | Not_initialized (* Initial state *) - | Too_late (* already in a submodule, too late to initialize *) - | Path of string * string list (* Actually initialized *) - -(* Reference storing the path to the currently preprocessed module *) -let conv_path_ref = ref Not_initialized - -let get_conv_path_el () = - match !conv_path_ref with - | Path (e, el) -> e, el - | _ -> failwith "Pa_type_conv: path not set" - -(* Get path to the currently preprocessed module *) -let get_conv_path () = fst (get_conv_path_el ()) - -(* Set path to the currently preprocessed module *) -let set_conv_path conv_path = - if !conv_path_ref = Not_initialized || !Sys.interactive then - conv_path_ref := Path (conv_path, [conv_path]) - else failwith "Pa_type_conv: module name set twice" - -let () = if !Sys.interactive then set_conv_path "Toplevel" - -let push_conv_path mod_name = - match !conv_path_ref with - | Not_initialized -> conv_path_ref := Too_late (* Entered a submodule *) - | Too_late -> () - | Path (str, rev_lst) -> - conv_path_ref := Path (str ^ "." ^ mod_name, mod_name :: rev_lst) - -let pop_conv_path () = - match !conv_path_ref with - | Path (_, _ :: rev_lst) -> - conv_path_ref := Path (String.concat "." (List.rev rev_lst), rev_lst) - | _ -> () - - -module Signature_stack = struct - module Item = struct - type t = Ast.sig_item list ref - - let create () = ref [] - - let delayed_sigs t = List.rev !t - let delay_sig t item = t := item :: !t - end - - let bottom : Item.t = Item.create () - let stack : Item.t list ref = ref [bottom] - - let push () = - stack := Item.create () :: !stack - - let pop () = - match !stack with - | [] -> failwith "BUG: signature stack is empty" - | top :: rest -> stack := rest; top - - let top () = - match !stack with - | [] -> failwith "BUG: signature stack is empty" - | top :: _ -> top -end - -(* Generator registration *) - -type 'str_or_sig generator = -[ `Actual_generator of - (Gram.Token.t * Syntax.Gram.token_info) list option -> - bool -> - Syntax.Ast.ctyp -> - 'str_or_sig -| `Set of string list ] - -(* Map of "with"-generators for types in structures *) -let generators : (string, Ast.str_item generator) Hashtbl.t = Hashtbl.create 0 - -(* Map of "with"-generators for types in signatures *) -let sig_generators : (string, Ast.sig_item generator) Hashtbl.t = Hashtbl.create 0 - -(* Map of "with"-generators for exceptions in structures *) -let exn_generators : (string, Ast.str_item generator) Hashtbl.t = Hashtbl.create 0 - -(* Map of "with"-generators for exceptions in signatures *) -let sig_exn_generators : (string, Ast.sig_item generator) Hashtbl.t = Hashtbl.create 0 - -(* Map of "with"-generators for record fields *) -type record_field_generator = Ast.ctyp -> unit -let record_field_generators : (string, unit generator) Hashtbl.t = Hashtbl.create 0 - -(* Check that there is no argument for generators that do not expect any *) -let no_arg id e arg = - if arg = None then e - else - failwith ( - "Pa_type_conv: generator '" ^ id ^ "' does not expect an argument") - -(* Parse a list of tokens with the given grammar entry *) -let parse_with entry = function - | Some tokens -> - Some (Gram.parse_tokens_after_filter entry (Stream.of_list tokens)) - | None -> None - -(* Entry which ignores its input *) -let ignore_tokens = Gram.Entry.of_parser "ignore_tokens" ignore - -let make_generator entry e = - `Actual_generator (fun arg rec_ typ -> e (parse_with entry arg) rec_ typ) - -(* Add new generator, fail if already defined *) -let safe_add_gen gens id gen_or_set = - if Hashtbl.mem gens id then - failwith ("Pa_type_conv: generator '" ^ id ^ "' defined multiple times") - else Hashtbl.add gens id gen_or_set - -(* Register a "with"-generator for types in structures *) -let add_generator_with_arg ?(is_exn = false) id entry e = - let gens = if is_exn then exn_generators else generators in - safe_add_gen gens id (make_generator entry e) - -let add_generator ?is_exn id e = - add_generator_with_arg ?is_exn id ignore_tokens (no_arg id e) - -(* Remove a "with"-generator for types in structures *) -let rm_generator ?(is_exn = false) id = - let gens = if is_exn then exn_generators else generators in - Hashtbl.remove gens id - -(* Register a "with"-generator for types in signatures *) -let add_sig_generator_with_arg ?(delayed = false) ?(is_exn = false) id entry e = - let e = - if not delayed then e - else fun arg rec_ tds -> - Signature_stack.Item.delay_sig - (Signature_stack.top ()) - (e arg rec_ tds); - Ast.SgNil Loc.ghost - in - let gens = if is_exn then sig_exn_generators else sig_generators in - safe_add_gen gens id (make_generator entry e) - -let add_sig_generator ?delayed ?is_exn id e = - add_sig_generator_with_arg ?delayed ?is_exn id ignore_tokens (no_arg id e) - -(* Remove a "with"-generator for types in signatures *) -let rm_sig_generator ?(is_exn = false) id = - let gens = if is_exn then sig_exn_generators else sig_generators in - Hashtbl.remove gens id - -(* Register a "with"-generator for record fields *) -let add_record_field_generator_with_arg id entry e = - let e arg _rec tp = e arg tp in - safe_add_gen record_field_generators id (make_generator entry e) - -let add_record_field_generator id e = - add_record_field_generator_with_arg id ignore_tokens (no_arg id e) - -(* Remove a "with"-generator for record fields *) -let rm_record_field_generator id = Hashtbl.remove record_field_generators id - -let add_set_with_tbl ~tbl ~id ~set ~descr = - if List.mem id set then - failwith (Printf.sprintf "Set of generator %s for %s is recursive" id descr); - - try - let absent = List.find (fun id -> not (Hashtbl.mem tbl id)) set in - failwith ( - sprintf "Set of generator %s for %s contains the generator %s, which is undefined" - id descr absent - ) - with Not_found -> - safe_add_gen tbl id (`Set set) - -let add_sig_set ?(is_exn = false) id ~set = - let tbl = if is_exn then sig_exn_generators else sig_generators in - let descr = if is_exn then "exceptions in signature items" else "types in signature items" in - add_set_with_tbl ~tbl ~id ~set ~descr - -let add_str_set ?(is_exn = false) id ~set = - let tbl = if is_exn then exn_generators else generators in - let descr = if is_exn then "exceptions in structure items" else "types in structure items" in - add_set_with_tbl ~tbl ~id ~set ~descr - -let add_set ~kind ~is_exn id ~set = - let exn_poss = - match is_exn with - | `Yes -> [true] - | `No -> [false] - | `Both -> [true; false] in - let add_poss = - match kind with - | `Str -> [add_str_set] - | `Sig -> [add_sig_set] - | `Both -> [add_str_set; add_sig_set] in - List.iter (fun (add : ?is_exn:_ -> _) -> - List.iter (fun is_exn -> - add ~is_exn id ~set - ) exn_poss - ) add_poss - -(* General purpose code generation module *) - -module Gen = struct - - (* same conversion as camlp4 does when converting its ast into ocaml's ast *) - let regular_constr_of_revised_constr = function - | " True" -> "True" - | " False" -> "False" - | "True" -> "true" - | "False" -> "false" - | s -> s - - (* Map of record field source locations to their default expression *) - let record_defaults : (Loc.t, Ast.expr) Hashtbl.t = Hashtbl.create 0 - - let find_record_default loc = - try Some (Hashtbl.find record_defaults loc) with Not_found -> None - - let gensym = - let cnt = ref 0 in - fun ?(prefix = "_x") () -> - incr cnt; - sprintf "%s__%03i_" prefix !cnt - - (* Like Ast.exSem_of_list but for application *) - let exApp_of_list l = - let rec aux = function - | [] -> Ast.ExNil Loc.ghost - | [x] -> x - | x :: xs -> - let loc = Ast.loc_of_expr x in - <:expr@loc< $aux xs$ $x$ >> - in - aux (List.rev l) - - let rec tyArr_of_list = function - | [] -> Ast.TyNil Loc.ghost - | [x] -> x - | x :: xs -> - let loc = loc_of_ctyp x in - <:ctyp@loc< $x$ -> $tyArr_of_list xs$ >> - - let rec paOr_of_list = function - | [] -> Ast.PaNil Loc.ghost - | [x] -> x - | x :: xs -> - let loc = loc_of_patt x in - <:patt@loc< $x$ | $paOr_of_list xs$ >> - - module PP = Camlp4.Printers.OCaml.Make (Syntax) - let conv_ctyp = (new PP.printer ~comments:false ())#ctyp - - let string_of_ctyp ctyp = - try - let buffer = Buffer.create 32 in - Format.bprintf buffer "%a@?" conv_ctyp ctyp; - Some (Buffer.contents buffer) - with _ -> None - - let error tp ~fn ~msg = - let loc = Ast.loc_of_ctyp tp in - let failure = - match string_of_ctyp tp with - | Some tp_str -> sprintf "%s: %s\n%s" fn msg tp_str - | None -> sprintf "%s: %s" fn msg - in - Loc.raise loc (Failure failure) - - let unknown_type tp fn = error tp ~fn ~msg:"unknown type" - - let rec ty_var_list_of_ctyp tp acc = - match tp with - | <:ctyp< $tp1$ $tp2$ >> -> - ty_var_list_of_ctyp tp1 (ty_var_list_of_ctyp tp2 acc) - | <:ctyp< '$param$ >> -> param :: acc - | _ -> invalid_arg "ty_var_list_of_ctyp" - - let rec get_rev_id_path tp acc = - match tp with - | <:ident< $id1$ . $id2$ >> -> get_rev_id_path id2 (get_rev_id_path id1 acc) - | <:ident< $lid:id$ >> | <:ident< $uid:id$ >> -> id :: acc - | _ -> invalid_arg "get_rev_id_path" - - let mk_ident _loc str = - let first = str.[0] in - if first >= 'A' && first <= 'Z' then <:ident< $uid:str$ >> - else <:ident< $lid:str$ >> - - let rec ident_of_rev_path _loc = function - | [str] -> mk_ident _loc str - | str :: strs -> - <:ident< $ident_of_rev_path _loc strs$ . $mk_ident _loc str$ >> - | _ -> invalid_arg "ident_of_rev_path" - - let rec get_appl_path _loc = function - | <:ctyp< $id:id$ >> -> id - | <:ctyp< $tp$ $_$ >> -> get_appl_path _loc tp - | _ -> failwith "get_appl_path: unknown type" - - let abstract _loc = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) - let apply _loc = List.fold_left (fun f arg -> <:expr< $f$ $arg$ >>) - - let switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil tp = - let rec loop = function - | <:ctyp< private $tp$ >> -> loop tp - | <:ctyp@loc< [ $alts$ ] >> -> sum loc alts - | <:ctyp@loc< [< $row_fields$ ] >> | <:ctyp@loc< [> $row_fields$ ] >> - | <:ctyp@loc< [= $row_fields$ ] >> -> variants loc row_fields - | <:ctyp@loc< $id:_$ >> - | <:ctyp@loc< ( $tup:_$ ) >> - | <:ctyp@loc< $_$ -> $_$ >> - | <:ctyp@loc< '$_$ >> - | <:ctyp@loc< $_$ $_$ >> as tp_def -> alias loc tp_def - | <:ctyp@loc< { $flds$ } >> -> record loc flds - | <:ctyp@loc< $tp1$ == $tp2$ >> -> mani loc tp1 tp2 - | <:ctyp@loc< >> -> nil loc - | tp -> unknown_type tp "switch_tp_def" - in - loop tp - - let rec mk_expr_lst _loc = function - | [] -> <:expr< [] >> - | e :: es -> <:expr< [$e$ :: $mk_expr_lst _loc es$] >> - - let rec mk_patt_lst _loc = function - | [] -> <:patt< [] >> - | p :: ps -> <:patt< [$p$ :: $mk_patt_lst _loc ps$] >> - - let get_tparam_id = function - | <:ctyp< '$id$ >> | <:ctyp< +'$id$ >> | <:ctyp< -'$id$ >> -> id - | tp -> error tp ~fn:"get_tparam_id" ~msg:"not a type parameter" - - exception Stop - let type_is_recursive short_circuit type_name = object (self) - inherit fold as super - method! ctyp ctyp = - match short_circuit ctyp with - | Some false -> self - | Some true -> raise Stop - | None -> - match ctyp with - | <:ctyp< $lid:_$ : $ctyp$ >> -> - (* or else we would say that [type t = { t : int }] is recursive *) - self#ctyp ctyp - | <:ctyp< $lid:id$ >> -> if id = type_name then raise Stop else self - | <:ctyp< $uid:_$ : $args$ -> $_return_type$ >> -> self#ctyp args - | <:ctyp< $uid:_$ : $_return_type$ >> -> self - | ctyp -> super#ctyp ctyp - end - let type_is_recursive ?(stop_on_functions = true) ?(short_circuit = fun _ -> None) type_name tp = - let short_circuit = - if stop_on_functions then - function - | <:ctyp< ( ~ $_$ : $_$ ) -> $_$ >> - | <:ctyp< ( ? $_$ : $_$ ) -> $_$ >> - | <:ctyp< $_$ -> $_$ >> -> Some false - | ctyp -> short_circuit ctyp - else short_circuit - in - try ignore ((type_is_recursive short_circuit type_name)#ctyp tp); false - with Stop -> true - - let drop_variance_annotations = - (map_ctyp (function - | <:ctyp@loc< +'$var$ >> | <:ctyp@loc< -'$var$ >> -> <:ctyp@loc< '$var$ >> - | tp -> tp))#ctyp - - let vars_of = object (self) - inherit fold as super - val vars = [] - method vars = vars - method! ctyp _ = self - method! ident = function - | <:ident< $lid:v$ >> -> {< vars = v :: vars >} - | ident -> super#ident ident - method! patt = function - | <:patt< $_$ = $p$ >> -> self#patt p - | p -> super#patt p - end - let lids_of_patt patt = - (vars_of#patt patt)#vars - - let ignore_everything = object (self) - inherit map as super - method! sig_item sig_item = - match super#sig_item sig_item with - | <:sig_item@loc< value $id$ : $ctyp$ >> -> - <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> - | sig_item -> sig_item - method! str_item str_item = - match super#str_item str_item with - | <:str_item@loc< value $rec:_$ $bindings$ >> as str_item -> ( - match self#ignore_binding bindings with - | None -> - str_item - | Some more_bindings -> - <:str_item@loc< - $str_item$; - value $more_bindings$; - >> - ) - | str_item -> str_item - method ignore_binding = function - | Ast.BiAnt _ - | <:binding< >> -> None - | <:binding@loc< $b1$ and $b2$ >> -> ( - match self#ignore_binding b1, self#ignore_binding b2 with - | b, None - | None, b -> b - | Some b1, Some b2 -> - Some <:binding@loc< $b1$ and $b2$ >> - ) - | <:binding@loc< $patt$ = $_$ >> -> - match lids_of_patt patt with - | [] -> None - | h :: t -> - let mk_binding acc lid = <:binding@loc< $acc$ and _ = $lid:lid$ >> in - Some (List.fold_left mk_binding <:binding@loc< _ = $lid:h$ >> t) - end - - let delay_sig_item sig_item = - Signature_stack.Item.delay_sig (Signature_stack.top ()) sig_item -end - -(* Functions for interpreting derivation types *) - -let find_generator ~name haystack = (); fun rec_ entry (needle,arg,gen_to_remove) -> - let seen = Hashtbl.create 0 in - let generators = ref [] in - (* enumerating the generators reachable from [needle] in no particular - order. If some generators depend on code generated by other generators, - we should probably change that and have a predictable order. - Set diff A \ B is implemented by marking all elements of B as seen - without adding them to [generators] and then visiting A. *) - let rec aux ~add = function - | [] -> () - | needle :: rest -> - if Hashtbl.mem seen needle then aux ~add rest - else ( - Hashtbl.add seen needle (); - match Hashtbl.find haystack needle with - | `Set set -> aux ~add (set @ rest) - | `Actual_generator g -> - if add then generators := g :: !generators; - aux ~add rest - ) in - let aux_with_error ~add needle = - try aux ~add [needle] - with Not_found -> - (* the first lookup is the only one that can fail because we check - when we define sets that they only reference known generators *) - let keys = Hashtbl.fold (fun key _ acc -> key :: acc) haystack [] in - let gen_names = String.concat ", " keys in - let msg = - Printf.sprintf - "Pa_type_conv: \ - %S is not a supported %s generator. (supported generators: %s)" - needle - name - gen_names in - failwith msg in - List.iter (aux_with_error ~add:false) gen_to_remove; - aux_with_error ~add:true needle; - - List.rev_map (fun genf -> - genf arg rec_ entry - ) !generators - -let generate = find_generator ~name:"type" generators - -let gen_derived_defs _loc rec_ tp drvs = - let coll drv der_sis = <:str_item< $der_sis$; $stSem_of_list (generate rec_ tp drv)$ >> in - List.fold_right coll drvs <:str_item< >> - -let generate_exn = find_generator ~name:"exception" exn_generators - -let gen_derived_exn_defs _loc tp drvs = - let coll drv der_sis = <:str_item< $der_sis$; $stSem_of_list (generate_exn false tp drv)$ >> in - List.fold_right coll drvs <:str_item< >> - -let sig_generate = find_generator ~name:"signature" sig_generators - -let gen_derived_sigs _loc rec_ tp drvs = - let coll drv der_sis = <:sig_item< $der_sis$; $sgSem_of_list (sig_generate rec_ tp drv)$ >> in - List.fold_right coll drvs (SgNil _loc) - -let sig_exn_generate = - find_generator ~name:"signature exception" sig_exn_generators - -let gen_derived_exn_sigs _loc tp drvs = - let coll drv der_sis = <:sig_item< $der_sis$; $sgSem_of_list (sig_exn_generate false tp drv)$ >> in - List.fold_right coll drvs (SgNil _loc) - -let remember_record_field_generators el drvs = - let act drv = - let gen = find_generator ~name:"record field" record_field_generators in - ignore (gen false el drv : unit list) - in - List.iter act drvs - -(* rewriting of non recursive type definition - [type nonrec t = t] - is rewritten - [include (struct - type fresh = t - type t = fresh - end : sig - type fresh = t - type t = fresh - end with type fresh := t - )] - This way, none of the intermediate types are exposed. -*) - -(* Note that type definitions like - - type nonrec t = t = {foo:int} - - won't work. You might think that it could be rewritten as: - - include (struct - type fresh = t = {foo:int} - type t = fresh = {foo:int} - end : sig - type fresh = t = {foo:int} - type t = fresh = {foo:int} - end with type fresh := t) - - but the compiler complains on fresh := t, and fresh := t = {foo:int} is not valid - syntax. -*) - -module Rewrite_tds : sig - val sig_ : Ast.loc -> bool -> Ast.ctyp -> Ast.sig_item - val str_ : Ast.loc -> bool -> Ast.ctyp -> Ast.str_item -end = struct - module StringSet = Set.Make(String) - module StringMap = Map.Make(String) - - let bound_names = object - inherit fold as super - val bound_names = [] - method bound_names = bound_names - method! ctyp = function - | Ast.TyDcl (_loc, n, tpl, tk, _cl) -> - {< bound_names = (n, tpl, tk) :: bound_names >} - | ctyp -> - super#ctyp ctyp - end - - let bound_names td = - (bound_names#ctyp td)#bound_names - - let rec match_type_constructor acc = function - | <:ctyp@_loc< $t1$ $t2$ >> -> - match_type_constructor ((t2,_loc) :: acc) t1 - | <:ctyp@_loc< $lid:id$ >> -> - Some (id, _loc, acc) - | _ -> - None - let rebuild_type_constructor (id, _loc, params) = - List.fold_left (fun acc (param, _loc) -> - <:ctyp< $acc$ $param$ >> - ) <:ctyp< $lid:id$ >> params - - let referenced_names used_bound bound = object (self) - inherit map as super - method! ctyp t = - match t with - | <:ctyp@loc< $lhs$ : $rhs$ >> -> - <:ctyp@loc< $lhs$ : $self#ctyp rhs$ >> - | _ -> - match match_type_constructor [] t with - | Some (id, _loc, params) -> - let id = - try - let new_, _, _ = StringMap.find id bound in - used_bound := StringMap.add id (_loc, List.length params) !used_bound; - new_ - with Not_found -> id in - let params = List.map (fun (param, _loc) -> (self#ctyp param, _loc)) params in - rebuild_type_constructor (id, _loc, params) - | None -> - super#ctyp t - end - - let gen = - let r = ref (-1) in - fun () -> incr r; Printf.sprintf "__pa_nonrec_%d" !r - - let referenced_names td = - let bound_names = bound_names td in - let bound_names_map = - List.fold_left (fun acc (name, tpl, tk) -> - StringMap.add name (gen (), tpl, tk) acc) - StringMap.empty bound_names in - let used_bound = ref StringMap.empty in - let td = (referenced_names used_bound bound_names_map)#ctyp td in - let bound_names_map = - StringMap.fold (fun key (v, tpl, tk) acc -> - try - let arity = StringMap.find key !used_bound in - StringMap.add key (v, arity, tpl, tk) acc - with Not_found -> acc - ) bound_names_map StringMap.empty in - td, bound_names_map, used_bound - - let params_of_arity (_loc, arity) = - Array.to_list ( - Array.init arity (fun i -> - <:ctyp< '$lid:sprintf "a%d" i$ >> - ) - ) - let constructor_of_arity t (_loc, arity) = - let args = List.map (fun param -> (param, _loc)) (params_of_arity (_loc, arity)) in - rebuild_type_constructor (t, _loc, args) - - let build_common _loc td = - let td2, map, _set = referenced_names td in - StringMap.fold (fun k (v, arity, tpl, tk) acc -> - let tydcl = - let tpl, rhs = - match tk with - | <:ctyp< $_$ == $_$ >> -> - (* Here we use the fact that when saying type nonrec ('a, 'b) t = ('a, 'b) t = ..., - the two list of parameters must be the same (not even shuffling one list is - allowed). *) - tpl, tk - | _ -> params_of_arity arity, constructor_of_arity k arity - in - TyDcl (_loc, v, tpl, rhs, []) - in - let new_constraints = - <:with_constr< type $constructor_of_arity v arity$ := $constructor_of_arity k arity$ >> - in - match acc with - | None -> - Some (tydcl, td2, new_constraints) - | Some (td1, td2, constraints) -> - let td1 = <:ctyp< $td1$ and $tydcl$ >> in - let constraints = <:with_constr< $constraints$ and $new_constraints$ >> in - Some (td1, td2, constraints)) - map None - - let str_ _loc rec_ td = - if rec_ then <:str_item< type $td$ >> else - match build_common _loc td with - | None -> <:str_item< type $td$ >> - | Some (td1, td2, constraints) -> - <:str_item< include (struct type $td1$; type $td2$; end : sig - type $td1$; type $td2$; - end with $constraints$) >> - - let sig_ _loc rec_ td = - if rec_ then <:sig_item< type $td$ >> else - match build_common _loc td with - | None -> <:sig_item< type $td$ >> - | Some (td1, td2, constraints) -> - <:sig_item< include (sig type $td1$; type $td2$; - end with $constraints$) >> -end - -(* Syntax extension *) - -open Syntax - -let is_prefix ~prefix x = - let prefix_len = String.length prefix in - String.length x >= prefix_len && prefix = String.sub x 0 prefix_len - -let chop_prefix ~prefix x = - if is_prefix ~prefix x then - let prefix_len = String.length prefix in - Some (String.sub x prefix_len (String.length x - prefix_len)) - else None - -let get_default_path _loc = - try - let prefix = Sys.getenv "TYPE_CONV_ROOT" in - match chop_prefix ~prefix (Loc.file_name (Loc.make_absolute _loc)) with - | Some x -> x ^ "#" - | None -> Loc.file_name _loc - with _ -> Loc.file_name _loc - -let set_conv_path_if_not_set _loc = - if !conv_path_ref = Not_initialized || !Sys.interactive then - let conv_path = get_default_path _loc in - conv_path_ref := Path (conv_path, [conv_path]) - -let found_module_name = - Gram.Entry.of_parser "found_module_name" (fun strm -> - match Stream.npeek 1 strm with - | [(UIDENT name, token_info)] -> - set_conv_path_if_not_set (Gram.token_location token_info); - push_conv_path name; - Stream.junk strm; - name - | _ -> raise Stream.Failure) - -let rec fetch_generator_arg paren_count acc strm = - let token, token_info as elt = Stream.next strm in - match token with - | KEYWORD "(" -> - fetch_generator_arg (paren_count + 1) (elt :: acc) strm - | KEYWORD ")" when paren_count = 1 -> - (EOI, token_info) :: acc - | KEYWORD ")" -> - fetch_generator_arg (paren_count - 1) (elt :: acc) strm - | EOI -> - Loc.raise (Gram.token_location token_info) (Stream.Error "')' missing") - | _ -> - fetch_generator_arg paren_count (elt :: acc) strm - -let rec_ = - Gram.Entry.of_parser "nonrec" (fun strm -> - match Stream.peek strm with - | Some (LIDENT "nonrec", _) -> - Stream.junk strm; - false - | _ -> - true) - -let generator_arg = - Gram.Entry.of_parser "generator_arg" (fun strm -> - match Stream.peek strm with - | Some (KEYWORD "(", _) -> - Stream.junk strm; - Some (List.rev (fetch_generator_arg 1 [] strm)) - | _ -> None) - -let mk_ctyp _loc name params = - List.fold_left (fun acc x -> - Ast.TyApp (_loc, acc, Gen.drop_variance_annotations x) - ) <:ctyp< $lid:name$ >> params - -let rec types_used_by_type_conv = function - | Ast.TyDcl (_loc, name, tps, _rhs, _cl) -> - <:str_item< value _ (_ : $mk_ctyp _loc name tps$) = () >> - | Ast.TyAnd (_loc, td1, td2) -> - <:str_item< - $types_used_by_type_conv td1$; - $types_used_by_type_conv td2$ - >> - | _ -> assert false - -let quotation_str_item = Gram.Entry.mk "quotation_str_item";; - -DELETE_RULE Gram str_item: "module"; a_UIDENT; module_binding0 END; -DELETE_RULE Gram str_item: "type"; type_declaration END; -DELETE_RULE Gram sig_item: "type"; type_declaration END; -DELETE_RULE Gram module_type: "sig"; sig_items; "end" END; - -EXTEND Gram - GLOBAL: quotation_str_item str_item sig_item label_declaration module_type; - - str_item: - [[ - "TYPE_CONV_PATH"; conv_path = STRING -> - set_conv_path conv_path; - <:str_item< >> - ]]; - - generator: [[ - (* disallowing arguments when subtracting because the meaning of things like - [type t with typehash(something) - typehash(somethingelse)] is unclear *) - [ id = LIDENT; l = LIST1 [ "-"; x = LIDENT -> x ] -> (id, None, l) - | id = LIDENT; arg = generator_arg -> (id, arg, []) ] - ]]; - - quotation_str_item: [[ - [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> - let str_item = gen_derived_defs _loc rec_ tds drvs in - Gen.ignore_everything#str_item str_item - ]]]; - - str_item: - [[ - [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> - set_conv_path_if_not_set _loc; - let str_item = gen_derived_defs _loc rec_ tds drvs in - let str_item = Gen.ignore_everything#str_item str_item in - <:str_item< - $Rewrite_tds.str_ _loc rec_ tds$; - $types_used_by_type_conv tds$; - $str_item$ - >> - | "type"; rec_ = rec_; tds = type_declaration -> - Rewrite_tds.str_ _loc rec_ tds - ]]]; - - str_item: - [[ - "exception"; tds = constructor_declaration; "with"; - drvs = LIST1 generator SEP "," -> - set_conv_path_if_not_set _loc; - let str_item = gen_derived_exn_defs _loc tds drvs in - let str_item = Gen.ignore_everything#str_item str_item in - <:str_item< exception $tds$; $str_item$ >> - ]]; - - str_item: - [[ - "module"; i = found_module_name; mb = module_binding0 -> - pop_conv_path (); - <:str_item< module $i$ = $mb$ >> - ]]; - - start_of_sig: - [[ "sig" -> Signature_stack.push () ]]; - - module_type: - [[ - start_of_sig; sg = sig_items; "end" -> - match Signature_stack.Item.delayed_sigs (Signature_stack.pop ()) with - | [] -> <:module_type< sig $sg$ end >> - | delayed_sigs -> - let delayed_sigs = List.map Gen.ignore_everything#sig_item delayed_sigs in - <:module_type< sig $sg$; $list:delayed_sigs$ end >> - ]]; - - sig_item: - [[ - [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> - set_conv_path_if_not_set _loc; - let sig_item = gen_derived_sigs _loc rec_ tds drvs in - let sig_item = Gen.ignore_everything#sig_item sig_item in - <:sig_item< $Rewrite_tds.sig_ _loc rec_ tds$; $sig_item$ >> - | "type"; rec_ = rec_; tds = type_declaration -> - Rewrite_tds.sig_ _loc rec_ tds - ]]]; - - sig_item: - [[ - "exception"; cd = constructor_declaration; "with"; - drvs = LIST1 generator SEP "," -> - set_conv_path_if_not_set _loc; - let sig_item = gen_derived_exn_sigs _loc cd drvs in - let sig_item = Gen.ignore_everything#sig_item sig_item in - <:sig_item< exception $cd$; $sig_item$ >> - ]]; - - label_declaration: - [[ name = a_LIDENT; ":"; tp = poly_type; - "with"; drvs = LIST1 generator SEP "," -> - let label_tp = Ast.TyLab (_loc, name, tp) in - remember_record_field_generators label_tp drvs; - <:ctyp< $lid:name$ : $tp$ >> - | "mutable"; name = a_LIDENT; ":"; tp = poly_type; - "with"; drvs = LIST1 generator SEP "," -> - let label_tp = Ast.TyMut (_loc, Ast.TyLab (_loc, name, tp)) in - remember_record_field_generators label_tp drvs; - <:ctyp< $lid:name$ : mutable $tp$ >> - ]]; -END - -let type_conv_quotation loc _loc_name_opt cnt_str = - set_conv_path_if_not_set loc; - let str_item = Gram.parse_string quotation_str_item loc cnt_str in - <:module_expr@loc< struct $str_item$ end >> - -let () = - (* <:type_conv< type t = ... >> outputs the generated code but discards the type definition *) - Quotation.add "type_conv" Quotation.DynAst.module_expr_tag type_conv_quotation - -(* Record field defaults *) - -(* Add "default" to set of record field generators *) -let () = - add_record_field_generator_with_arg "default" Syntax.expr - (fun expr_opt tp -> - let loc = Ast.loc_of_ctyp tp in - let default = - match expr_opt with - | Some expr -> expr - | None -> Loc.raise loc (Failure "could not parse default expression") - in - if Hashtbl.mem Gen.record_defaults loc then - Loc.raise loc (Failure "several default expressions are given"); - Hashtbl.replace Gen.record_defaults loc default) - -(* Removal of warnings (in signatures). - Because ocaml gives warnings but doesn't give a way to deactivate them, we have - plenty in the generated code. The most annoyings ones are the ones in signatures, - because they are harder to remove. - For instance: - module M : sig type t = [ `A ] with sexp end = ... - is likely to generate a warning 'unused value t_of_sexp__' in the signature (the same - warning in an implementation would be already removed). - To work around that, every auto generated 'val name : type' is replaced by - 'val name : type _no_unused_value_warning_'. - And in a second step (could probably be done in one step, but it would be complicated), - we try to generate an expression that will use these names (which we recognize because - of the mark), and whether we succeed or not, we remove the mark. - To use a 'val name : type' in a context like: - module M : sig val name : type end = ... - you simply need to do: - let _ = M.name - And there are other tricks depending on where the signature item appear. The removal of - warning doesn't handle all possible ways of generating warnings. *) - -module String_set = Set.Make(String) - -let qualify_idents loc m idents = - List.map (fun i -> <:ident@loc< $uid:m$.$i$ >>) idents -let use_idents loc idents = - List.fold_left - (fun acc i -> <:str_item@loc< $acc$; value _ = $id:i$; >>) - <:str_item@loc< >> idents -let use_idents_in loc idents body = - List.fold_left - (fun acc i -> <:expr@loc< let _ = $id:i$ in $acc$ >>) - body idents - -let ignore = object (self) - inherit Ast.map as super - - method! expr = function - | <:expr@loc< let module $uid:m$ : $module_type$ = $module_expr$ in $body$ >> -> - let module_expr = self#module_expr module_expr in - let idents, module_type = self#ignore_module_type module_type in - let body = self#expr body in - let body = use_idents_in loc (qualify_idents loc m idents) body in - <:expr@loc< let module $uid:m$ : $module_type$ = $module_expr$ in $body$ >> - | expr -> super#expr expr - - method! str_item = function - | <:str_item@loc< module type $s$ = $module_type$ >> -> - let idents, module_type = self#ignore_module_type module_type in - let warnings_removal = use_idents loc (qualify_idents loc s idents) in - if idents = [] - then <:str_item@loc< module type $s$ = $module_type$; >> - else <:str_item@loc< - module type $s$ = $module_type$; - value () = if True then () else begin - let module M($s$ : $uid:s$) = struct - $warnings_removal$; - end in - () - end; - >> - - | <:str_item@loc< module $uid:m$ : $module_type$ = $module_expr$ >> -> - let module_expr = self#module_expr module_expr in - let idents, module_type = self#ignore_module_type module_type in - let warnings_removal = use_idents loc (qualify_idents loc m idents) in - <:str_item@loc< module $uid:m$ : $module_type$ = $module_expr$; $warnings_removal$ >> - - | <:str_item@loc< include ($module_expr$ : $module_type$) >> -> - let module_expr = self#module_expr module_expr in - let idents, module_type = self#ignore_module_type module_type in - let warnings_removal = use_idents loc idents in - <:str_item@loc< include ($module_expr$ : $module_type$); $warnings_removal$ >> - - | StMod _ - | StSem _ - | StInc _ - | StNil _ - | StCls _ - | StClt _ - | StDir _ - | StExc _ - | StExp _ - | StExt _ - | StRecMod _ - | StOpn _ - | StTyp _ - | StVal _ - | StAnt _ as str_item -> - super#str_item str_item - - method fold_map_on_functor_arg warnings_removal = function - | MeFun (loc, s, mt, me) -> - (* wouldn't be quite right if you have a functor that takes several arguments with - the same name, but who would do that anyway? *) - let idents, mt = self#ignore_module_type mt in - let more_warnings_removal = use_idents loc (qualify_idents loc s idents) in - let warnings_removal = <:str_item@loc< $warnings_removal$; $more_warnings_removal$ >> in - let me = self#fold_map_on_functor_arg warnings_removal me in - MeFun (loc, s, mt, me) - | me -> - match self#module_expr me with - | MeStr (loc, str_item) -> - MeStr (loc, <:str_item@loc< $warnings_removal$; $str_item$ >>) - | MeTyc (loc, MeStr (loc2, str_item), mt) -> - MeTyc (loc, MeStr (loc2, <:str_item@loc2< $warnings_removal$; $str_item$ >>), mt) - | me -> - (* not ignoring the warnings in this case because we don't even know if $me$ is - a functor or not, which makes it impossible to find a way of inserting - $warnings_removal$ *) - me - - method! module_expr = function - | MeFun (loc, _, _, _) as me -> self#fold_map_on_functor_arg <:str_item@loc< >> me - - | MeStr _ - | MeTyc _ - | MeNil _ - | MeId _ - | MePkg _ - | MeAnt _ - | MeApp _ as me -> - super#module_expr me - - (* Strip all the 'markers' that have not been handled *) - method! sig_item = function - | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> - <:sig_item@loc< value $id$ : $ctyp$ >> - | sig_item -> super#sig_item sig_item - - method ignore_module_type = function - | MtNil _ - | MtId _ - | MtFun _ - | MtQuo _ - | MtOf _ - | MtAnt _ as mt -> - [], self#module_type mt - | MtSig (loc, sig_item) -> - let idents, sig_item = self#ignore_sig_item sig_item in - idents, MtSig (loc, sig_item) - | MtWit (loc, module_type, with_constr) -> - let idents, module_type = self#ignore_module_type module_type in - idents, MtWit (loc, module_type, with_constr) - - method ignore_sig_item sig_item = - let next_defs = String_set.empty in - let _next_defs, acc, sig_item = self#ignore_sig_item_aux next_defs [] sig_item in - acc, sig_item - method ignore_sig_item_aux next_defs acc = function - | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> - if String_set.mem id next_defs then - next_defs, acc, <:sig_item@loc< >> - else - let next_defs = String_set.add id next_defs in - let sig_item = <:sig_item@loc< value $id$ : $self#ctyp ctyp$ >> in - next_defs, <:ident@loc< $lid:id$ >> :: acc, sig_item - | <:sig_item< value $id$ : $_$ >> as sig_item -> - let sig_item = self#sig_item sig_item in - let next_defs = String_set.add id next_defs in - next_defs, acc, sig_item - | <:sig_item@loc< module $uid:m$ : $module_type$ >> -> - let new_idents, module_type = self#ignore_module_type module_type in - next_defs, acc @ qualify_idents loc m new_idents, <:sig_item@loc< module $uid:m$ : $module_type$ >> - | <:sig_item@loc< $si1$; $si2$ >> -> - (* in here, we are traversing from right to left, so that when see an identifier - we already know whether a further 'val ...' will hide it *) - let next_defs, acc, si2 = self#ignore_sig_item_aux next_defs acc si2 in - let next_defs, acc, si1 = self#ignore_sig_item_aux next_defs acc si1 in - next_defs, acc, <:sig_item@loc< $si1$; $si2$ >> - | sig_item -> next_defs, acc, self#sig_item sig_item -end - -let strip = object - inherit Ast.map as super - - method! sig_item = function - | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> - <:sig_item@loc< value $id$ : $ctyp$ >> - | sig_item -> super#sig_item sig_item -end - -let () = - (* above, the parser used 'sig' and 'end' as anchors but an mli is a signature - without the sig and end. So here we catch all the elements that have been inserted - at toplevel in the mli *) - let _, current_sig_parser = Register.current_parser () in - Register.register_sig_item_parser (fun ?directive_handler _loc stream -> - let mli = current_sig_parser ?directive_handler _loc stream in - match Signature_stack.Item.delayed_sigs Signature_stack.bottom with - | [] -> mli - | sig_items -> <:sig_item< $list: mli :: sig_items$ >> - ); - AstFilters.register_sig_item_filter strip#sig_item; - AstFilters.register_str_item_filter ignore#str_item; - AstFilters.register_topphrase_filter ignore#str_item diff -Nru type-conv-111.13.00/lib/pa_type_conv.mli type-conv-113.00.02/lib/pa_type_conv.mli --- type-conv-111.13.00/lib/pa_type_conv.mli 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/lib/pa_type_conv.mli 1970-01-01 00:00:00.000000000 +0000 @@ -1,268 +0,0 @@ -(** Pa_type_conv: Preprocessing Module for Registering Type Conversions *) - -open Camlp4.PreCast.Ast - -(** {6 Generator registration} *) - -val set_conv_path_if_not_set : Loc.t -> unit -(** [set_conv_path_if_not_set loc] sets the path to the file/module being - converted for improved error messages. *) - -val get_conv_path : unit -> string -(** [get_conv_path ()] @return the name to module containing a type - as required for error messages. *) - -val add_generator : ?is_exn : bool -> string -> (bool -> ctyp -> str_item) -> unit -(** [add_generator ?is_exn name gen] adds the code generator [gen], - which maps type or exception declarations to structure items, where - [is_exn] specifies whether the declaration is an exception. Note that - the original type/exception declarations get added automatically in - any case. - - @param is_exn = [false] -*) - -val add_generator_with_arg : - ?is_exn : bool -> string -> 'a Camlp4.PreCast.Gram.Entry.t -> - ('a option -> bool -> ctyp -> str_item) -> unit -(** [add_generator_with_arg ?is_exn name entry generator] same as - [add_generator], but the generator may accept an argument, which is - parsed with [entry]. *) - -val rm_generator : ?is_exn : bool -> string -> unit -(** [rm_generator ?is_exn name] removes the code generator named [name] - for types if [is_exn] is [false], or exceptions otherwise. - - @param is_exn = [false] -*) - -val add_sig_generator : - ?delayed : bool -> ?is_exn : bool -> - string -> (bool -> ctyp -> sig_item) -> unit -(** [add_sig_generator ?delayed ?is_exn name gen] adds the code generator [gen], - which maps type or exception declarations to signature items, where - [is_exn] specifies whether the declaration is an exception. Note that the - original type/exception declarations get added automatically in any case. If - [delayed] is set to true, the output of this generator is appended to the - signature in which it's defined - - @param delayed = [false] - @param is_exn = [false] -*) - -val add_sig_generator_with_arg : - ?delayed : bool -> ?is_exn : bool -> string -> - 'a Camlp4.PreCast.Gram.Entry.t -> - ('a option -> bool -> ctyp -> sig_item) -> unit -(** [add_sig_generator_with_arg ?delayed ?is_exn name entry generator] same as - [add_sig_generator], but the generator may accept an argument, - which is parsed with [entry]. *) - -val rm_sig_generator : ?is_exn : bool -> string -> unit -(** [rm_sig_generator ?is_exn name] removes the signature code generator named - [name] for types if [is_exn] is [false], or exceptions otherwise. - - @param is_exn = [false] -*) - -(** Type of record field code generators *) -type record_field_generator = ctyp -> unit - -val add_record_field_generator : string -> record_field_generator -> unit -(** [add_record_field_generator gen_name gen] adds the record field code - generator [gen] with name [gen_name], which acts on the location - identifying the record field. *) - -val add_record_field_generator_with_arg : - string -> 'a Camlp4.PreCast.Gram.Entry.t -> - ('a option -> record_field_generator) -> unit -(** [add_record_field_generator_with_arg name entry generator] same as - [add_record_field_generator], but the [generator] takes an argument, - which is parsed with [entry]. If [None] is passed to the generator, - parsing of the argument failed, otherwise [Some arg] will be passed, - where [arg] is the successfully parsed argument. *) - -val rm_record_field_generator : string -> unit -(** [rm_record_field_generator name] removes the record field code generator - named [name]. *) - -(** {6 Generator sets registration} *) - -val add_sig_set : ?is_exn: bool -> string -> set: string list -> unit -(** [add_sig_set ?is_exn id ~set] adds the generator [id] to the list - of generators for signatures. - This generator will behave as if is all the generators from [set] - had been given instead. Any duplicate arising from repeatedly - expanding such generators are removed. - If [is_exn], then it is a generator for exception declaration, or - else it is a generator for type declaration. -*) - -val add_str_set : ?is_exn: bool -> string -> set: string list -> unit -(** [add_str_set ?is_exn id ~set] behaves exactly like - [add_sig_set ?is_exn id ~set] but for structure items instead of - signatures items. -*) - -val add_set : - kind:[`Str | `Sig | `Both] -> - is_exn:[`Yes | `No | `Both] -> - string -> - set:string list -> - unit -(** [add_set ~kind ~is_exn id ~set] is a shorthand for doing multiple - calls to [add_str_set] and [add_sig_set] -*) - -(** {6 Utility functions} *) - -val get_loc_err : Loc.t -> string -> string -(** [get_loc_err loc msg] generates a compile-time error message. *) - -val hash_variant : string -> int -(** [hash_variant str] @return the integer encoding a variant tag with - name [str]. *) - - -(** {6 General purpose code generation module} *) - -module Gen : sig - - val regular_constr_of_revised_constr : string -> string - (* Transforms names of constructor of sum types (including polymorphic variants) from - their revised representation in the camlp4 ast to the representation they would - have in ocaml's ast. - - This is supposed to be used like this: - match ctyp with - | <:ctyp< $uid:constr$ >> -> - <:expr< $str:regular_constr_of_revised_constr constr$ >> - | _ -> ... - - so that <:ctyp< True >> becomes "true" and <:ctyp< True >> (assuming regular - ocaml in the quotation) becomes "True" and not " True". - - Everything also applies to exception names. *) - - val exApp_of_list : expr list -> expr - (** [expr_app_of_list l] takes list [l] of expressions [e1; e2; e3; ...] - and returns the expression [e1 e2 e3]. C.f.: [Ast.exSem_of_list]. *) - - val tyArr_of_list : ctyp list -> ctyp - (** [tyArr_of_list l] takes list [l] of types [e1; e2; e3; ...] and - returns the type [e1 -> e2 -> e3]. C.f.: [Ast.exSem_of_list]. *) - - val paOr_of_list : patt list -> patt - (** [paOr_of_list l] takes list [l] of patterns [p1; p2; p3; ...] and returns - the pattern [p1 | p2 | p3 | ...] *) - - val gensym : ?prefix : string -> unit -> string - (** [gensym ?prefix ()] generates a fresh variable name with [prefix]. - When used with the default parameters, it will return: [_x__001], - [_x__002], [_x__003], ... - - @param prefix default = "_x" - *) - - val error : ctyp -> fn : string -> msg : string -> _ - (** [error tp ~fn ~msg] raises an error with [msg] on type [tp] occuring - in function [fn]. *) - - val unknown_type : ctyp -> string -> _ - (** [unknown_type tp fn] type [tp] cannot be handled by function [fn]. *) - - val ty_var_list_of_ctyp : ctyp -> string list -> string list - (** [ty_var_list_of_ctyp tp acc] accumulates a list of type parameters - contained in [tp] into [acc] as strings. *) - - val get_rev_id_path : ident -> string list -> string list - (** [get_rev_id_path id acc] takes an identifier. @return a reversed - module path (list of strings) denoting this identifier, appending - it to [acc]. *) - - val ident_of_rev_path : Loc.t -> string list -> ident - (** [ident_of_rev_path loc path] takes a location [loc] and a reversed path - [rev_path] to an identifier. @return identifier denoting the - bound value. *) - - val get_appl_path : Loc.t -> ctyp -> ident - (** [get_appl_path loc tp] @return the identifier path associated with - a polymorphic type. *) - - val abstract : Loc.t -> patt list -> expr -> expr - (** [abstract loc patts body] takes a location [loc], a pattern list - [patts], and an expression [body]. @return a function expression - that takes the patterns as arguments, and binds them in [body]. *) - - val apply : Loc.t -> expr -> expr list -> expr - (** [apply loc f_expr arg_exprs] takes a location [loc], an expression - [f_expr] representing a function, and a list of argument expressions - [arg_exprs]. @return an expression in which the function is - applied to its arguments. *) - - val switch_tp_def : - alias : (Loc.t -> ctyp -> 'a) -> - sum : (Loc.t -> ctyp -> 'a) -> - record : (Loc.t -> ctyp -> 'a) -> - variants : (Loc.t -> ctyp -> 'a) -> - mani : (Loc.t -> ctyp -> ctyp -> 'a) -> - nil : (Loc.t -> 'a) -> - ctyp - -> 'a - (** [switch_tp_def ~alias ~sum ~record ~variants ~mani tp_def] - takes a handler function for each kind of type definition and - applies the appropriate handler when [tp_def] matches. *) - - val mk_expr_lst : Loc.t -> expr list -> expr - (** [mk_expr_lst loc expr_list] takes a list of expressions. - @return an expression representing a list of expressions. *) - - val mk_patt_lst : Loc.t -> patt list -> patt - (** [mk_patt_lst _loc patt_list] takes a list of patterns. - @return a pattern representing a list of patterns. *) - - val get_tparam_id : ctyp -> string - (** [get_tparam_id tp] @return the string identifier associated with - [tp] if it is a type parameter. @raise Failure otherwise. *) - - val type_is_recursive : - ?stop_on_functions:bool -> - ?short_circuit:(ctyp -> bool option) -> - string -> ctyp -> bool - (** [type_is_recursive ?short_circuit id tp] - @return whether the type [tp] with name [id] - refers to itself, assuming that it is not mutually recursive with - another type. - - @param short_circuit allows you to override the search for certain - type expressions. - @param stop_on_functions allows to disregard the recursive occurences appearing in - arrow types. The default is to disregard them. - *) - - val drop_variance_annotations : ctyp -> ctyp - (** [drop_variance_annotations tp] @return the type resulting from dropping - all variance annotations in [tp]. *) - - val find_record_default : Loc.t -> expr option - (** [find_record_default loc] @return the optional default expression - associated with the record field at source location [loc] if defined. *) - - val delay_sig_item : sig_item -> unit - (** [delay_sig_item item] places [item] at the end of the current signature *) -end - -(** {6 Utility functions to rewrite type definitions} *) - -module Rewrite_tds : sig - val sig_ : Loc.t -> bool -> ctyp -> sig_item - (** [sig_ loc rec_ typedefs] rewrites the given type definition to make it either - recursive or non recursive. - For instance, the parser calls [sig_ loc false (TyDcl (_, t, [], t, []))] when it - encouters [type t = t] and calls [sig_ loc true (TyDcl (_, t, [], t, []))] when it - encouters [type nonrec t = t] in signatures. *) - - val str_ : Loc.t -> bool -> ctyp -> str_item - (** [str_ loc rec_ typedefs] does the same thing as [sig_ loc rec_ typedefs], except - that it returns a structure item instead of a signature item. *) -end diff -Nru type-conv-111.13.00/lib/pa_type_conv.mllib type-conv-113.00.02/lib/pa_type_conv.mllib --- type-conv-111.13.00/lib/pa_type_conv.mllib 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/lib/pa_type_conv.mllib 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 4688111c934ddd0f4ac3eded6942b27f) -Pa_type_conv -# OASIS_STOP diff -Nru type-conv-111.13.00/myocamlbuild.ml type-conv-113.00.02/myocamlbuild.ml --- type-conv-111.13.00/myocamlbuild.ml 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/myocamlbuild.ml 2015-09-24 18:04:37.000000000 +0000 @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 8163f09ce2973938a02abc8976da18dc) *) +(* DO NOT EDIT (digest: dec95aade8fb3fe3b2be383f8defd032) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -39,10 +39,10 @@ open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -52,10 +52,10 @@ | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -204,26 +204,27 @@ end - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) in - var_expand (MapString.find name env) + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env let var_choose lst env = @@ -233,7 +234,7 @@ end -# 236 "myocamlbuild.ml" +# 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) @@ -248,6 +249,9 @@ *) open Ocamlbuild_plugin + type conf = + { no_automatic_syntax: bool; + } (* these functions are not really officially exported *) let run_and_read = @@ -258,6 +262,31 @@ Ocamlbuild_pack.Lexers.blank_sep_strings + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + let split s ch = let buf = Buffer.create 13 in let x = ref [] in @@ -285,30 +314,36 @@ with Not_found -> s (* ocamlfind command *) - let ocamlfind x = - let ocamlfind_prog = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get "ocamlfind" env - with Not_found -> - Printf.eprintf "W: Cannot get variable ocamlfind"; - "ocamlfind" - in - S[Sh ocamlfind_prog; x] + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] - let dispatch = + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch conf = function - | Before_options -> + | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) @@ -325,27 +360,39 @@ * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - let syn_args = [A"-syntax"; A "camlp4o"] in - let args = - (* Heuristic to identify syntax extensions: whether they end in - * ".syntax"; some might not *) - if Filename.check_suffix pkg "syntax" - then syn_args @ base_args - else base_args - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - end - (find_packages ()); + if not (conf.no_automatic_syntax) then begin + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) @@ -394,10 +441,10 @@ module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string + type dir = string + type file = string + type name = string + type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) @@ -412,7 +459,7 @@ * directory. *) includes: (dir * dir list) list; - } + } let env_filename = @@ -455,7 +502,7 @@ try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> - Printf.eprintf "W: Cannot get variable %s" var) + Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; @@ -510,12 +557,13 @@ (* When ocaml link something that use the C library, then one need that file to be up to date. + This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -531,39 +579,45 @@ (* Add flags *) List.iter (fun (tags, cond_specs) -> - let spec = - BaseEnvLight.var_choose cond_specs env + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec in - flag tags & spec) + flag tags & (eval_specs spec)) t.flags | _ -> () - let dispatch_default t = + let dispatch_default conf t = dispatch_combine [ dispatch t; - MyOCamlbuildFindlib.dispatch; + MyOCamlbuildFindlib.dispatch conf; ] end -# 554 "myocamlbuild.ml" +# 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { - MyOCamlbuildBase.lib_ocaml = [("pa_type_conv", ["lib"], [])]; + MyOCamlbuildBase.lib_ocaml = [("pa_type_conv", ["src"], [])]; lib_c = []; flags = []; includes = [] } ;; -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} + +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 568 "myocamlbuild.ml" +# 622 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff -Nru type-conv-111.13.00/_oasis type-conv-113.00.02/_oasis --- type-conv-111.13.00/_oasis 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/_oasis 2015-09-24 18:04:37.000000000 +0000 @@ -2,11 +2,11 @@ OCamlVersion: >= 4.00.0 FindlibVersion: >= 1.3.2 Name: type_conv -Version: 111.13.00 +Version: 113.00.00 Synopsis: type_conv - support library for preprocessor type conversions -Authors: Jane Street Capital LLC -Copyrights: (C) 2005-2013 Jane Street Capital LLC -Maintainers: Jane Street Capital LLC +Authors: Jane Street Group, LLC +Copyrights: (C) 2005-2013 Jane Street Group LLC +Maintainers: Jane Street Group, LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/type_conv @@ -16,7 +16,7 @@ BuildTools: ocamlbuild, camlp4o Library pa_type_conv - Path: lib + Path: src FindlibName: type_conv Modules: Pa_type_conv BuildDepends: camlp4.quotations, camlp4.extend diff -Nru type-conv-111.13.00/README.md type-conv-113.00.02/README.md --- type-conv-111.13.00/README.md 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/README.md 2015-09-24 18:04:37.000000000 +0000 @@ -34,7 +34,7 @@ In the case of bugs, feature requests, contributions and similar, please contact the maintainers: - * Jane Street Capital, LLC + * Jane Street Group, LLC Up-to-date information should be available at: * diff -Nru type-conv-111.13.00/setup.ml type-conv-113.00.02/setup.ml --- type-conv-111.13.00/setup.ml 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/setup.ml 2015-09-24 18:04:37.000000000 +0000 @@ -1,7 +1,7 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 0cf4d7cc88f7f09e745394d1251a8eaf) *) +(* DO NOT EDIT (digest: f4382801a404bd5846d8f711eb548f27) *) (* - Regenerated by OASIS v0.4.1 + Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -50,6 +50,7 @@ type t = { + (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; @@ -86,19 +87,31 @@ {!default with quiet = true} - let args () = + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), - (s_ " Run quietly"); + s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), - (s_ " Display information message"); + s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), - (s_ " Output debug message")] + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct @@ -227,11 +240,9 @@ let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf end @@ -243,29 +254,62 @@ open OASISGettext - module MapString = Map.Make(String) + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t - let map_string_of_assoc assoc = - List.fold_left - (fun acc (k, v) -> MapString.add k v acc) - MapString.empty - assoc + let of_list lst = add_list empty lst + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end - module SetString = Set.Make(String) + module MapString = MapExt.Make(String) - let set_string_add_list st lst = - List.fold_left - (fun acc e -> SetString.add e acc) - st - lst + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) - let set_string_of_list = - set_string_add_list - SetString.empty + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) let compare_csl s1 s2 = @@ -284,6 +328,13 @@ Hashtbl.hash (String.lowercase s) end) + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + let varname_of_string ?(hyphen='_') s = if String.length s = 0 then @@ -684,7 +735,7 @@ type s = string - type t = string + type t = string type comparator = @@ -695,7 +746,7 @@ | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + (* Range of allowed characters *) @@ -890,17 +941,17 @@ - type license = string + type license = string - type license_exception = string + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + type license_dep_5_unit = @@ -909,20 +960,19 @@ excption: license_exception option; version: license_version; } - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + end @@ -937,10 +987,10 @@ open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -950,10 +1000,10 @@ | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -1026,6 +1076,21 @@ end +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + +end + module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) @@ -1033,40 +1098,40 @@ - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + type tool = | ExternalTool of name | InternalExecutable of name - + type vcs = @@ -1079,7 +1144,7 @@ | Arch | Monotone | OtherVCS of url - + type plugin_kind = @@ -1107,7 +1172,7 @@ ] - type 'a plugin = 'a * name * OASISVersion.t option + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin @@ -1119,7 +1184,7 @@ (* # 115 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices + type 'a conditional = 'a OASISExpr.choices type custom = @@ -1127,7 +1192,7 @@ pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + type common_section = @@ -1136,7 +1201,7 @@ cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + type build_section = @@ -1156,7 +1221,7 @@ bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + type library = @@ -1167,28 +1232,28 @@ lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; - } + } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; - } + } type executable = { exec_custom: bool; exec_main_is: unix_filename; - } + } type flag = { flag_description: string option; flag_default: bool conditional; - } + } type source_repository = @@ -1200,7 +1265,7 @@ src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } type test = @@ -1211,7 +1276,7 @@ test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } type doc_format = @@ -1222,7 +1287,7 @@ | Info of unix_filename | DVI | OtherDoc - + type doc = @@ -1238,7 +1303,7 @@ doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } type section = @@ -1249,7 +1314,7 @@ | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + type section_kind = @@ -1258,42 +1323,43 @@ type package = { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: string option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } end @@ -1346,6 +1412,24 @@ let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) end type origin = @@ -1386,6 +1470,17 @@ let beta = InDev Beta + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + let data_check t data origin = let no_message = "no message" in @@ -1618,6 +1713,25 @@ create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") + + let no_automatic_syntax = + create "no_automatic_syntax" alpha + (fun () -> + s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ + that matches the internal heuristic (if a dependency ends with \ + a .syntax or is a well known syntax).") end module OASISUnixPath = struct @@ -1988,16 +2102,6 @@ lst in - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - (* The .cmx that be compiled along *) let cmxs = let should_be_built = @@ -2023,12 +2127,32 @@ [] in + (* The headers and annot/cmt files that should be compiled along *) + let headers = + let sufx = + if lib.lib_pack + then [".cmti"; ".cmt"; ".annot"] + else [".cmi"; ".cmti"; ".cmt"; ".annot"] + in + List.map + begin + List.fold_left + begin fun accu s -> + let dot = String.rindex s '.' in + let base = String.sub s 0 dot in + List.map ((^) base) sufx @ accu + end + [] + end + (find_modules lib.lib_modules "cmi") + in + (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc + [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in @@ -2388,13 +2512,13 @@ in let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) + lazy begin + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty + end in let library_name_of_findlib_name fndlb_nm = try @@ -2706,14 +2830,17 @@ let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then - begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end let glob ~ctxt fn = @@ -2761,7 +2888,7 @@ end -# 2766 "setup.ml" +# 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2836,26 +2963,27 @@ end - let var_get name env = - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) in - var_expand (MapString.find name env) + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env let var_choose lst env = @@ -2865,15 +2993,15 @@ end -# 2870 "setup.ml" +# 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) - + (* TODO: get rid of this module. *) open OASISContext - let args = args + let args () = fst (fspecs ()) let default = default @@ -5004,11 +5132,14 @@ s_ " Don't try to update setup.ml, even if _oasis has changed.") + let default_oasis_fn = "_oasis" + + let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn - | None -> "_oasis" + | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with @@ -5106,7 +5237,8 @@ try match t.oasis_digest with | Some dgst -> - if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then begin do_update (); true @@ -5272,7 +5404,7 @@ end -# 5277 "setup.ml" +# 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5708,6 +5840,17 @@ lst in + let make_fnames modul sufx = + List.fold_right + begin fun sufx accu -> + (String.capitalize modul ^ sufx) :: + (String.uncapitalize modul ^ sufx) :: + accu + end + sufx + [] + in + (** Install all libraries *) let install_libs pkg = @@ -5728,27 +5871,29 @@ OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc lib.lib_modules in @@ -5796,27 +5941,29 @@ OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end acc obj.obj_modules in @@ -6121,7 +6268,7 @@ end -# 6126 "setup.ml" +# 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6133,10 +6280,15 @@ open OASISGettext open BaseEnv open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list - let ocamlbuild_clean_ev = - "ocamlbuild-clean" + let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = @@ -6174,6 +6326,11 @@ else []; + if bool_of_string (tests ()) then + ["-tag"; "tests"] + else + []; + if bool_of_string (profile ()) then ["-tag"; "profile"] else @@ -6259,27 +6416,7 @@ ref (fun lst -> lst) - type ocamlbuild_plugin = - { - plugin_tags: string option; - extra_args: string list; - } - - - let check_ocaml_version version pkg = - match pkg.ocaml_version with - | Some ocaml_version -> - let min_ocaml_version = OASISVersion.version_of_string version in - OASISVersion.comparator_ge min_ocaml_version ocaml_version - | None -> - false - - - let ocamlbuild_supports_ocamlfind = check_ocaml_version "3.12.1" - let ocamlbuild_supports_plugin_tags = check_ocaml_version "4.01" - - - let build t pkg argv = + let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -6423,33 +6560,13 @@ (BaseBuilt.register bt bnm lst) in - let cond_targets = - (* Run the hook *) - !cond_targets_hook cond_targets - in + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in - let extra_args = - match t.plugin_tags with - | Some tags -> "-plugin-tags" :: ("'" ^ tags ^ "'") :: t.extra_args - | None -> t.extra_args - in - let extra_args = - if ocamlbuild_supports_ocamlfind pkg then - "-use-ocamlfind" :: extra_args - else - extra_args - in - - (* Run a list of target... *) - run_ocamlbuild - (List.flatten - (List.map snd cond_targets) - @ extra_args) - argv; - (* ... and register events *) - List.iter - check_and_register - (List.flatten (List.map fst cond_targets)) + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = @@ -6486,12 +6603,18 @@ + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + - let doc_build path pkg (cs, doc) argv = + let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ - path; + run.run_path; cs.cs_name^".docdir"; "index.html"; ] @@ -6500,11 +6623,11 @@ OASISHostPath.make [ build_dir argv; - OASISHostPath.of_unix path; + OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in - run_ocamlbuild [index_html] argv; + run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register @@ -6515,7 +6638,7 @@ ["*.html"; "*.css"] - let doc_clean t pkg (cs, doc) argv = + let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name @@ -6523,15 +6646,13 @@ end -# 6528 "setup.ml" +# 6651 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; - build = - OCamlbuildPlugin.build - {OCamlbuildPlugin.plugin_tags = None; extra_args = []}; + build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = []; doc = []; install = InternalInstallPlugin.install; @@ -6550,7 +6671,7 @@ alpha_features = []; beta_features = []; name = "type_conv"; - version = "111.13.00"; + version = "113.00.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6562,11 +6683,11 @@ license_file = Some "LICENSE.txt"; copyrights = [ - "(C) 2005-2013 Jane Street Capital LLC " + "(C) 2005-2013 Jane Street Group LLC " ]; maintainers = - ["Jane Street Capital LLC "]; - authors = ["Jane Street Capital LLC "]; + ["Jane Street Group"; "LLC "]; + authors = ["Jane Street Group"; "LLC "]; homepage = Some "https://github.com/janestreet/type_conv"; synopsis = "type_conv - support library for preprocessor type conversions"; @@ -6617,7 +6738,7 @@ { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib"; + bs_path = "src"; bs_compiled_object = Best; bs_build_depends = [ @@ -6650,12 +6771,13 @@ (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; + disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.1"; - oasis_digest = Some "\021\023\161R\129\132\133\253\151tt\159\231 0x3FFFFFFF then !accu - (1 lsl 31) else !accu + +let () = assert (Obj.magic `Latency_stats = hash_variant "Latency_stats") + +(* Module/File path management *) + +type path = + | Not_initialized (* Initial state *) + | Too_late (* already in a submodule, too late to initialize *) + | Path of string * string list (* Actually initialized *) + +(* Reference storing the path to the currently preprocessed module *) +let conv_path_ref = ref Not_initialized + +let get_conv_path_el () = + match !conv_path_ref with + | Path (e, el) -> e, el + | _ -> failwith "Pa_type_conv: path not set" + +(* Get path to the currently preprocessed module *) +let get_conv_path () = fst (get_conv_path_el ()) + +(* Set path to the currently preprocessed module *) +let set_conv_path conv_path = + if !conv_path_ref = Not_initialized || !Sys.interactive then + conv_path_ref := Path (conv_path, [conv_path]) + else failwith "Pa_type_conv: module name set twice" + +let () = if !Sys.interactive then set_conv_path "Toplevel" + +let push_conv_path mod_name = + match !conv_path_ref with + | Not_initialized -> conv_path_ref := Too_late (* Entered a submodule *) + | Too_late -> () + | Path (str, rev_lst) -> + conv_path_ref := Path (str ^ "." ^ mod_name, mod_name :: rev_lst) + +let pop_conv_path () = + match !conv_path_ref with + | Path (_, _ :: rev_lst) -> + conv_path_ref := Path (String.concat "." (List.rev rev_lst), rev_lst) + | _ -> () + + +module Signature_stack = struct + module Item = struct + type t = Ast.sig_item list ref + + let create () = ref [] + + let delayed_sigs t = List.rev !t + let delay_sig t item = t := item :: !t + end + + let bottom : Item.t = Item.create () + let stack : Item.t list ref = ref [bottom] + + let push () = + stack := Item.create () :: !stack + + let pop () = + match !stack with + | [] -> failwith "BUG: signature stack is empty" + | top :: rest -> stack := rest; top + + let top () = + match !stack with + | [] -> failwith "BUG: signature stack is empty" + | top :: _ -> top +end + +(* Generator registration *) + +type 'str_or_sig generator = +[ `Actual_generator of + (Gram.Token.t * Syntax.Gram.token_info) list option -> + bool -> + Syntax.Ast.ctyp -> + 'str_or_sig +| `Set of string list ] + +(* Map of "with"-generators for types in structures *) +let str_generators : (string, Ast.str_item generator) Hashtbl.t = Hashtbl.create 0 + +(* Map of "with"-generators for types in signatures *) +let sig_generators : (string, Ast.sig_item generator) Hashtbl.t = Hashtbl.create 0 + +(* Map of "with"-generators for exceptions in structures *) +let str_exn_generators : (string, Ast.str_item generator) Hashtbl.t = Hashtbl.create 0 + +(* Map of "with"-generators for exceptions in signatures *) +let sig_exn_generators : (string, Ast.sig_item generator) Hashtbl.t = Hashtbl.create 0 + +(* Map of "with"-generators for record fields *) +type record_field_generator = Ast.ctyp -> unit +let record_field_generators : (string, unit generator) Hashtbl.t = Hashtbl.create 0 + +(* Check that there is no argument for generators that do not expect any *) +let no_arg id e arg = + if arg = None then e + else + failwith ( + "Pa_type_conv: generator '" ^ id ^ "' does not expect an argument") + +(* Parse a list of tokens with the given grammar entry *) +let parse_with entry = function + | Some tokens -> + Some (Gram.parse_tokens_after_filter entry (Stream.of_list tokens)) + | None -> None + +(* Entry which ignores its input *) +let ignore_tokens = Gram.Entry.of_parser "ignore_tokens" ignore + +let make_generator entry e = + `Actual_generator (fun arg rec_ typ -> e (parse_with entry arg) rec_ typ) + +(* Add new generator, fail if already defined *) +let safe_add_gen gens id gen_or_set = + if Hashtbl.mem gens id then + failwith ("Pa_type_conv: generator '" ^ id ^ "' defined multiple times") + else Hashtbl.add gens id gen_or_set + +(* Register a "with"-generator for types in structures *) +let add_generator_with_arg ?(is_exn = false) id entry e = + let gens = if is_exn then str_exn_generators else str_generators in + safe_add_gen gens id (make_generator entry e) + +let add_generator ?is_exn id e = + add_generator_with_arg ?is_exn id ignore_tokens (no_arg id e) + +(* Remove a "with"-generator for types in structures *) +let rm_generator ?(is_exn = false) id = + let gens = if is_exn then str_exn_generators else str_generators in + Hashtbl.remove gens id + +(* Register a "with"-generator for types in signatures *) +let add_sig_generator_with_arg ?(delayed = false) ?(is_exn = false) id entry e = + let e = + if not delayed then e + else fun arg rec_ tds -> + Signature_stack.Item.delay_sig + (Signature_stack.top ()) + (e arg rec_ tds); + Ast.SgNil Loc.ghost + in + let gens = if is_exn then sig_exn_generators else sig_generators in + safe_add_gen gens id (make_generator entry e) + +let add_sig_generator ?delayed ?is_exn id e = + add_sig_generator_with_arg ?delayed ?is_exn id ignore_tokens (no_arg id e) + +(* Remove a "with"-generator for types in signatures *) +let rm_sig_generator ?(is_exn = false) id = + let gens = if is_exn then sig_exn_generators else sig_generators in + Hashtbl.remove gens id + +(* Register a "with"-generator for record fields *) +let add_record_field_generator_with_arg id entry e = + let e arg _rec tp = e arg tp in + safe_add_gen record_field_generators id (make_generator entry e) + +let add_record_field_generator id e = + add_record_field_generator_with_arg id ignore_tokens (no_arg id e) + +(* Remove a "with"-generator for record fields *) +let rm_record_field_generator id = Hashtbl.remove record_field_generators id + +let add_set_with_tbl ~tbl ~id ~set ~descr = + if List.mem id set then + failwith (Printf.sprintf "Set of generator %s for %s is recursive" id descr); + + try + let absent = List.find (fun id -> not (Hashtbl.mem tbl id)) set in + failwith ( + sprintf "Set of generator %s for %s contains the generator %s, which is undefined" + id descr absent + ) + with Not_found -> + safe_add_gen tbl id (`Set set) + +let add_sig_set ?(is_exn = false) id ~set = + let tbl = if is_exn then sig_exn_generators else sig_generators in + let descr = if is_exn then "exceptions in signature items" else "types in signature items" in + add_set_with_tbl ~tbl ~id ~set ~descr + +let add_str_set ?(is_exn = false) id ~set = + let tbl = if is_exn then str_exn_generators else str_generators in + let descr = if is_exn then "exceptions in structure items" else "types in structure items" in + add_set_with_tbl ~tbl ~id ~set ~descr + +let add_set ~kind ~is_exn id ~set = + let exn_poss = + match is_exn with + | `Yes -> [true] + | `No -> [false] + | `Both -> [true; false] in + let add_poss = + match kind with + | `Str -> [add_str_set] + | `Sig -> [add_sig_set] + | `Both -> [add_str_set; add_sig_set] in + List.iter (fun (add : ?is_exn:_ -> _) -> + List.iter (fun is_exn -> + add ~is_exn id ~set + ) exn_poss + ) add_poss + +(* General purpose code generation module *) + +module Gen = struct + + (* same conversion as camlp4 does when converting its ast into ocaml's ast *) + let regular_constr_of_revised_constr = function + | " True" -> "True" + | " False" -> "False" + | "True" -> "true" + | "False" -> "false" + | s -> s + + (* Map of record field source locations to their default expression *) + let record_defaults : (Loc.t, Ast.expr) Hashtbl.t = Hashtbl.create 0 + + let find_record_default loc = + try Some (Hashtbl.find record_defaults loc) with Not_found -> None + + let gensym = + let cnt = ref 0 in + fun ?(prefix = "_x") () -> + incr cnt; + sprintf "%s__%03i_" prefix !cnt + + (* Like Ast.exSem_of_list but for application *) + let exApp_of_list l = + let rec aux = function + | [] -> Ast.ExNil Loc.ghost + | [x] -> x + | x :: xs -> + let loc = Ast.loc_of_expr x in + <:expr@loc< $aux xs$ $x$ >> + in + aux (List.rev l) + + let rec tyArr_of_list = function + | [] -> Ast.TyNil Loc.ghost + | [x] -> x + | x :: xs -> + let loc = loc_of_ctyp x in + <:ctyp@loc< $x$ -> $tyArr_of_list xs$ >> + + let rec paOr_of_list = function + | [] -> Ast.PaNil Loc.ghost + | [x] -> x + | x :: xs -> + let loc = loc_of_patt x in + <:patt@loc< $x$ | $paOr_of_list xs$ >> + + module PP = Camlp4.Printers.OCaml.Make (Syntax) + let conv_ctyp = (new PP.printer ~comments:false ())#ctyp + + let string_of_ctyp ctyp = + try + let buffer = Buffer.create 32 in + Format.bprintf buffer "%a@?" conv_ctyp ctyp; + Buffer.contents buffer + with _ -> + "Cannot print type." + + let error tp ~fn ~msg = + let loc = Ast.loc_of_ctyp tp in + let failure = sprintf "%s: %s\n%s" fn msg (string_of_ctyp tp) in + Loc.raise loc (Failure failure) + + let unknown_type tp fn = error tp ~fn ~msg:"unknown type" + + let rec ty_var_list_of_ctyp tp acc = + match tp with + | <:ctyp< $tp1$ $tp2$ >> -> + ty_var_list_of_ctyp tp1 (ty_var_list_of_ctyp tp2 acc) + | <:ctyp< '$param$ >> -> param :: acc + | _ -> invalid_arg "ty_var_list_of_ctyp" + + let rec get_rev_id_path tp acc = + match tp with + | <:ident< $id1$ . $id2$ >> -> get_rev_id_path id2 (get_rev_id_path id1 acc) + | <:ident< $lid:id$ >> | <:ident< $uid:id$ >> -> id :: acc + | _ -> invalid_arg "get_rev_id_path" + + let mk_ident _loc str = + let first = str.[0] in + if first >= 'A' && first <= 'Z' then <:ident< $uid:str$ >> + else <:ident< $lid:str$ >> + + let rec ident_of_rev_path _loc = function + | [str] -> mk_ident _loc str + | str :: strs -> + <:ident< $ident_of_rev_path _loc strs$ . $mk_ident _loc str$ >> + | _ -> invalid_arg "ident_of_rev_path" + + let rec get_appl_path _loc = function + | <:ctyp< $id:id$ >> -> id + | <:ctyp< $tp$ $_$ >> -> get_appl_path _loc tp + | _ -> failwith "get_appl_path: unknown type" + + let abstract _loc = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) + let apply _loc = List.fold_left (fun f arg -> <:expr< $f$ $arg$ >>) + + let switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil tp = + let rec loop = function + | <:ctyp< private $tp$ >> -> loop tp + | <:ctyp@loc< [ $alts$ ] >> -> sum loc alts + | <:ctyp@loc< [< $row_fields$ ] >> | <:ctyp@loc< [> $row_fields$ ] >> + | <:ctyp@loc< [= $row_fields$ ] >> -> variants loc row_fields + | <:ctyp@loc< $id:_$ >> + | <:ctyp@loc< ( $tup:_$ ) >> + | <:ctyp@loc< $_$ -> $_$ >> + | <:ctyp@loc< '$_$ >> + | <:ctyp@loc< $_$ $_$ >> as tp_def -> alias loc tp_def + | <:ctyp@loc< { $flds$ } >> -> record loc flds + | <:ctyp@loc< $tp1$ == $tp2$ >> -> mani loc tp1 tp2 + | <:ctyp@loc< >> -> nil loc + | tp -> unknown_type tp "switch_tp_def" + in + loop tp + + let rec mk_expr_lst _loc = function + | [] -> <:expr< [] >> + | e :: es -> <:expr< [$e$ :: $mk_expr_lst _loc es$] >> + + let rec mk_patt_lst _loc = function + | [] -> <:patt< [] >> + | p :: ps -> <:patt< [$p$ :: $mk_patt_lst _loc ps$] >> + + let get_tparam_id = function + | <:ctyp< '$id$ >> | <:ctyp< +'$id$ >> | <:ctyp< -'$id$ >> -> id + | tp -> error tp ~fn:"get_tparam_id" ~msg:"not a type parameter" + + exception Stop + let type_is_recursive short_circuit type_name = object (self) + inherit fold as super + method! ctyp ctyp = + match short_circuit ctyp with + | Some false -> self + | Some true -> raise Stop + | None -> + match ctyp with + | <:ctyp< $lid:_$ : $ctyp$ >> -> + (* or else we would say that [type t = { t : int }] is recursive *) + self#ctyp ctyp + | <:ctyp< $lid:id$ >> -> if id = type_name then raise Stop else self + | <:ctyp< $uid:_$ : $args$ -> $_return_type$ >> -> self#ctyp args + | <:ctyp< $uid:_$ : $_return_type$ >> -> self + | ctyp -> super#ctyp ctyp + end + let type_is_recursive ?(stop_on_functions = true) ?(short_circuit = fun _ -> None) type_name tp = + let short_circuit = + if stop_on_functions then + function + | <:ctyp< ( ~ $_$ : $_$ ) -> $_$ >> + | <:ctyp< ( ? $_$ : $_$ ) -> $_$ >> + | <:ctyp< $_$ -> $_$ >> -> Some false + | ctyp -> short_circuit ctyp + else short_circuit + in + try ignore ((type_is_recursive short_circuit type_name)#ctyp tp); false + with Stop -> true + + let drop_variance_annotations = + (map_ctyp (function + | <:ctyp@loc< +'$var$ >> | <:ctyp@loc< -'$var$ >> -> <:ctyp@loc< '$var$ >> + | tp -> tp))#ctyp + + let vars_of = object (self) + inherit fold as super + val vars = [] + method vars = vars + method! ctyp _ = self + method! ident = function + | <:ident< $lid:v$ >> -> {< vars = v :: vars >} + | ident -> super#ident ident + method! patt = function + | <:patt< $_$ = $p$ >> -> self#patt p + | p -> super#patt p + end + let lids_of_patt patt = + (vars_of#patt patt)#vars + + let ignore_everything = object (self) + inherit map as super + method! sig_item sig_item = + match super#sig_item sig_item with + | <:sig_item@loc< value $id$ : $ctyp$ >> -> + <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> + | sig_item -> sig_item + method! str_item str_item = + match super#str_item str_item with + | <:str_item@loc< value $rec:_$ $bindings$ >> as str_item -> ( + match self#ignore_binding bindings with + | None -> + str_item + | Some more_bindings -> + <:str_item@loc< + $str_item$; + value $more_bindings$; + >> + ) + | str_item -> str_item + method ignore_binding = function + | Ast.BiAnt _ + | <:binding< >> -> None + | <:binding@loc< $b1$ and $b2$ >> -> ( + match self#ignore_binding b1, self#ignore_binding b2 with + | b, None + | None, b -> b + | Some b1, Some b2 -> + Some <:binding@loc< $b1$ and $b2$ >> + ) + | <:binding@loc< $patt$ = $_$ >> -> + match lids_of_patt patt with + | [] -> None + | h :: t -> + let mk_binding acc lid = <:binding@loc< $acc$ and _ = $lid:lid$ >> in + Some (List.fold_left mk_binding <:binding@loc< _ = $lid:h$ >> t) + end + + let delay_sig_item sig_item = + Signature_stack.Item.delay_sig (Signature_stack.top ()) sig_item +end + +(* Functions for interpreting derivation types *) + +let find_generator ~name haystack = (); fun rec_ entry (needle,arg,gen_to_remove) -> + let seen = Hashtbl.create 0 in + let generators = ref [] in + (* enumerating the generators reachable from [needle] in no particular + order. If some generators depend on code generated by other generators, + we should probably change that and have a predictable order. + Set diff A \ B is implemented by marking all elements of B as seen + without adding them to [generators] and then visiting A. *) + let rec aux ~add = function + | [] -> () + | needle :: rest -> + if Hashtbl.mem seen needle then aux ~add rest + else ( + Hashtbl.add seen needle (); + match Hashtbl.find haystack needle with + | `Set set -> aux ~add (set @ rest) + | `Actual_generator g -> + if add then generators := g :: !generators; + aux ~add rest + ) in + let aux_with_error ~add needle = + try aux ~add [needle] + with Not_found -> + (* the first lookup is the only one that can fail because we check + when we define sets that they only reference known generators *) + let keys = Hashtbl.fold (fun key _ acc -> key :: acc) haystack [] in + let gen_names = String.concat ", " keys in + let msg = + Printf.sprintf + "Pa_type_conv: \ + %S is not a supported %s generator. (supported generators: %s)" + needle + name + gen_names in + failwith msg in + List.iter (aux_with_error ~add:false) gen_to_remove; + aux_with_error ~add:true needle; + + List.rev_map (fun genf -> + genf arg rec_ entry + ) !generators + +let str_generate = find_generator ~name:"type" str_generators + +let gen_derived_defs _loc rec_ tp drvs = + let coll drv der_sis = <:str_item< $der_sis$; $stSem_of_list (str_generate rec_ tp drv)$ >> in + List.fold_right coll drvs <:str_item< >> + +let generate_exn = find_generator ~name:"exception" str_exn_generators + +let gen_derived_exn_defs _loc tp drvs = + let coll drv der_sis = <:str_item< $der_sis$; $stSem_of_list (generate_exn false tp drv)$ >> in + List.fold_right coll drvs <:str_item< >> + +let sig_generate = find_generator ~name:"signature" sig_generators + +let gen_derived_sigs _loc rec_ tp drvs = + let coll drv der_sis = <:sig_item< $der_sis$; $sgSem_of_list (sig_generate rec_ tp drv)$ >> in + List.fold_right coll drvs (SgNil _loc) + +let sig_exn_generate = + find_generator ~name:"signature exception" sig_exn_generators + +let gen_derived_exn_sigs _loc tp drvs = + let coll drv der_sis = <:sig_item< $der_sis$; $sgSem_of_list (sig_exn_generate false tp drv)$ >> in + List.fold_right coll drvs (SgNil _loc) + +let remember_record_field_generators el drvs = + let act drv = + let gen = find_generator ~name:"record field" record_field_generators in + ignore (gen false el drv : unit list) + in + List.iter act drvs + +(* rewriting of non recursive type definition + [type nonrec t = t] + is rewritten + [include (struct + type fresh = t + type t = fresh + end : sig + type fresh = t + type t = fresh + end with type fresh := t + )] + This way, none of the intermediate types are exposed. +*) + +(* Note that type definitions like + + type nonrec t = t = {foo:int} + + won't work. You might think that it could be rewritten as: + + include (struct + type fresh = t = {foo:int} + type t = fresh = {foo:int} + end : sig + type fresh = t = {foo:int} + type t = fresh = {foo:int} + end with type fresh := t) + + but the compiler complains on fresh := t, and fresh := t = {foo:int} is not valid + syntax. +*) + +module Rewrite_tds : sig + val sig_ : Ast.loc -> bool -> Ast.ctyp -> Ast.sig_item + val str_ : Ast.loc -> bool -> Ast.ctyp -> Ast.str_item +end = struct + module StringSet = Set.Make(String) + module StringMap = Map.Make(String) + + let bound_names = object + inherit fold as super + val bound_names = [] + method bound_names = bound_names + method! ctyp = function + | Ast.TyDcl (_loc, n, tpl, tk, _cl) -> + {< bound_names = (n, tpl, tk) :: bound_names >} + | ctyp -> + super#ctyp ctyp + end + + let bound_names td = + (bound_names#ctyp td)#bound_names + + let rec match_type_constructor acc = function + | <:ctyp@_loc< $t1$ $t2$ >> -> + match_type_constructor ((t2,_loc) :: acc) t1 + | <:ctyp@_loc< $lid:id$ >> -> + Some (id, _loc, acc) + | _ -> + None + let rebuild_type_constructor (id, _loc, params) = + List.fold_left (fun acc (param, _loc) -> + <:ctyp< $acc$ $param$ >> + ) <:ctyp< $lid:id$ >> params + + let referenced_names used_bound bound = object (self) + inherit map as super + method! ctyp t = + match t with + | <:ctyp@loc< $lhs$ : $rhs$ >> -> + <:ctyp@loc< $lhs$ : $self#ctyp rhs$ >> + | _ -> + match match_type_constructor [] t with + | Some (id, _loc, params) -> + let id = + try + let new_, _, _ = StringMap.find id bound in + used_bound := StringMap.add id (_loc, List.length params) !used_bound; + new_ + with Not_found -> id in + let params = List.map (fun (param, _loc) -> (self#ctyp param, _loc)) params in + rebuild_type_constructor (id, _loc, params) + | None -> + super#ctyp t + end + + let gen = + let r = ref (-1) in + fun () -> incr r; Printf.sprintf "__pa_nonrec_%d" !r + + let referenced_names td = + let bound_names = bound_names td in + let bound_names_map = + List.fold_left (fun acc (name, tpl, tk) -> + StringMap.add name (gen (), tpl, tk) acc) + StringMap.empty bound_names in + let used_bound = ref StringMap.empty in + let td = (referenced_names used_bound bound_names_map)#ctyp td in + let bound_names_map = + StringMap.fold (fun key (v, tpl, tk) acc -> + try + let arity = StringMap.find key !used_bound in + StringMap.add key (v, arity, tpl, tk) acc + with Not_found -> acc + ) bound_names_map StringMap.empty in + td, bound_names_map, used_bound + + let params_of_arity (_loc, arity) = + Array.to_list ( + Array.init arity (fun i -> + <:ctyp< '$lid:sprintf "a%d" i$ >> + ) + ) + let constructor_of_arity t (_loc, arity) = + let args = List.map (fun param -> (param, _loc)) (params_of_arity (_loc, arity)) in + rebuild_type_constructor (t, _loc, args) + + let build_common _loc td = + let td2, map, _set = referenced_names td in + StringMap.fold (fun k (v, arity, tpl, tk) acc -> + let tydcl = + let tpl, rhs = + match tk with + | <:ctyp< $_$ == $_$ >> -> + (* Here we use the fact that when saying type nonrec ('a, 'b) t = ('a, 'b) t = ..., + the two list of parameters must be the same (not even shuffling one list is + allowed). *) + tpl, tk + | _ -> params_of_arity arity, constructor_of_arity k arity + in + TyDcl (_loc, v, tpl, rhs, []) + in + let new_constraints = + <:with_constr< type $constructor_of_arity v arity$ := $constructor_of_arity k arity$ >> + in + match acc with + | None -> + Some (tydcl, td2, new_constraints) + | Some (td1, td2, constraints) -> + let td1 = <:ctyp< $td1$ and $tydcl$ >> in + let constraints = <:with_constr< $constraints$ and $new_constraints$ >> in + Some (td1, td2, constraints)) + map None + + let str_ _loc rec_ td = + if rec_ then <:str_item< type $td$ >> else + match build_common _loc td with + | None -> <:str_item< type $td$ >> + | Some (td1, td2, constraints) -> + <:str_item< include (struct type $td1$; type $td2$; end : sig + type $td1$; type $td2$; + end with $constraints$) >> + + let sig_ _loc rec_ td = + if rec_ then <:sig_item< type $td$ >> else + match build_common _loc td with + | None -> <:sig_item< type $td$ >> + | Some (td1, td2, constraints) -> + <:sig_item< include (sig type $td1$; type $td2$; + end with $constraints$) >> +end + +(* Syntax extension *) + +open Syntax + +let is_prefix ~prefix x = + let prefix_len = String.length prefix in + String.length x >= prefix_len && prefix = String.sub x 0 prefix_len + +let chop_prefix ~prefix x = + if is_prefix ~prefix x then + let prefix_len = String.length prefix in + Some (String.sub x prefix_len (String.length x - prefix_len)) + else None + +let get_default_path _loc = + try + let prefix = Sys.getenv "TYPE_CONV_ROOT" in + match chop_prefix ~prefix (Loc.file_name (Loc.make_absolute _loc)) with + | Some x -> x ^ "#" + | None -> Loc.file_name _loc + with _ -> Loc.file_name _loc + +let set_conv_path_if_not_set _loc = + if !conv_path_ref = Not_initialized || !Sys.interactive then + let conv_path = get_default_path _loc in + conv_path_ref := Path (conv_path, [conv_path]) + +let found_module_name = + Gram.Entry.of_parser "found_module_name" (fun strm -> + match Stream.npeek 1 strm with + | [(UIDENT name, token_info)] -> + set_conv_path_if_not_set (Gram.token_location token_info); + push_conv_path name; + Stream.junk strm; + name + | _ -> raise Stream.Failure) + +let rec fetch_generator_arg paren_count acc strm = + let token, token_info as elt = Stream.next strm in + match token with + | KEYWORD "(" -> + fetch_generator_arg (paren_count + 1) (elt :: acc) strm + | KEYWORD ")" when paren_count = 1 -> + (EOI, token_info) :: acc + | KEYWORD ")" -> + fetch_generator_arg (paren_count - 1) (elt :: acc) strm + | EOI -> + Loc.raise (Gram.token_location token_info) (Stream.Error "')' missing") + | _ -> + fetch_generator_arg paren_count (elt :: acc) strm + +let rec_ = + Gram.Entry.of_parser "nonrec" (fun strm -> + match Stream.peek strm with + | Some ((LIDENT "nonrec" | KEYWORD "nonrec"), _) -> + Stream.junk strm; + false + | _ -> + true) + +let generator_arg = + Gram.Entry.of_parser "generator_arg" (fun strm -> + match Stream.peek strm with + | Some (KEYWORD "(", _) -> + Stream.junk strm; + Some (List.rev (fetch_generator_arg 1 [] strm)) + | _ -> None) + +let mk_ctyp _loc name params = + List.fold_left (fun acc x -> + Ast.TyApp (_loc, acc, Gen.drop_variance_annotations x) + ) <:ctyp< $lid:name$ >> params + +let rec types_used_by_type_conv = function + | Ast.TyDcl (_loc, name, tps, _rhs, _cl) -> + <:str_item< value _ (_ : $mk_ctyp _loc name tps$) = () >> + | Ast.TyAnd (_loc, td1, td2) -> + <:str_item< + $types_used_by_type_conv td1$; + $types_used_by_type_conv td2$ + >> + | _ -> assert false + +let quotation_str_item = Gram.Entry.mk "quotation_str_item";; + +let () = + let delete_without_nonrec = + try + DELETE_RULE Gram str_item: "type"; type_declaration END; + DELETE_RULE Gram sig_item: "type"; type_declaration END; + None + with e -> Some e + and delete_with_nonrec = + try + let opt_nonrec = Gram.Entry.mk "opt_nonrec" in + DELETE_RULE Gram str_item: "type"; opt_nonrec; type_declaration END; + DELETE_RULE Gram sig_item: "type"; opt_nonrec; type_declaration END; + None + with e -> Some e + in + match delete_without_nonrec, delete_with_nonrec with + | None , None -> assert false + | Some _, None + | None , Some _ -> () + | Some e, Some _ -> raise e +;; + +DELETE_RULE Gram str_item: "module"; a_UIDENT; module_binding0 END; +DELETE_RULE Gram module_type: "sig"; sig_items; "end" END; + +EXTEND Gram + GLOBAL: quotation_str_item str_item sig_item label_declaration module_type; + + str_item: + [[ + "TYPE_CONV_PATH"; conv_path = STRING -> + set_conv_path conv_path; + <:str_item< >> + ]]; + + generator: [[ + (* disallowing arguments when subtracting because the meaning of things like + [type t with typehash(something) - typehash(somethingelse)] is unclear *) + [ id = LIDENT; l = LIST1 [ "-"; x = LIDENT -> x ] -> (id, None, l) + | id = LIDENT; arg = generator_arg -> (id, arg, []) ] + ]]; + + quotation_str_item: [[ + [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> + let str_item = gen_derived_defs _loc rec_ tds drvs in + Gen.ignore_everything#str_item str_item + ]]]; + + str_item: + [[ + [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> + set_conv_path_if_not_set _loc; + let str_item = gen_derived_defs _loc rec_ tds drvs in + let str_item = Gen.ignore_everything#str_item str_item in + <:str_item< + $Rewrite_tds.str_ _loc rec_ tds$; + $types_used_by_type_conv tds$; + $str_item$ + >> + | "type"; rec_ = rec_; tds = type_declaration -> + Rewrite_tds.str_ _loc rec_ tds + ]]]; + + str_item: + [[ + "exception"; tds = constructor_declaration; "with"; + drvs = LIST1 generator SEP "," -> + set_conv_path_if_not_set _loc; + let str_item = gen_derived_exn_defs _loc tds drvs in + let str_item = Gen.ignore_everything#str_item str_item in + <:str_item< exception $tds$; $str_item$ >> + ]]; + + str_item: + [[ + "module"; i = found_module_name; mb = module_binding0 -> + pop_conv_path (); + <:str_item< module $i$ = $mb$ >> + ]]; + + start_of_sig: + [[ "sig" -> Signature_stack.push () ]]; + + module_type: + [[ + start_of_sig; sg = sig_items; "end" -> + match Signature_stack.Item.delayed_sigs (Signature_stack.pop ()) with + | [] -> <:module_type< sig $sg$ end >> + | delayed_sigs -> + let delayed_sigs = List.map Gen.ignore_everything#sig_item delayed_sigs in + <:module_type< sig $sg$; $list:delayed_sigs$ end >> + ]]; + + sig_item: + [[ + [ "type"; rec_ = rec_; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," -> + set_conv_path_if_not_set _loc; + let sig_item = gen_derived_sigs _loc rec_ tds drvs in + let sig_item = Gen.ignore_everything#sig_item sig_item in + <:sig_item< $Rewrite_tds.sig_ _loc rec_ tds$; $sig_item$ >> + | "type"; rec_ = rec_; tds = type_declaration -> + Rewrite_tds.sig_ _loc rec_ tds + ]]]; + + sig_item: + [[ + "exception"; cd = constructor_declaration; "with"; + drvs = LIST1 generator SEP "," -> + set_conv_path_if_not_set _loc; + let sig_item = gen_derived_exn_sigs _loc cd drvs in + let sig_item = Gen.ignore_everything#sig_item sig_item in + <:sig_item< exception $cd$; $sig_item$ >> + ]]; + + label_declaration: + [[ name = a_LIDENT; ":"; tp = poly_type; + "with"; drvs = LIST1 generator SEP "," -> + let label_tp = Ast.TyLab (_loc, name, tp) in + remember_record_field_generators label_tp drvs; + <:ctyp< $lid:name$ : $tp$ >> + | "mutable"; name = a_LIDENT; ":"; tp = poly_type; + "with"; drvs = LIST1 generator SEP "," -> + let label_tp = Ast.TyMut (_loc, Ast.TyLab (_loc, name, tp)) in + remember_record_field_generators label_tp drvs; + <:ctyp< $lid:name$ : mutable $tp$ >> + ]]; +END + +let type_conv_quotation loc _loc_name_opt cnt_str = + set_conv_path_if_not_set loc; + let str_item = Gram.parse_string quotation_str_item loc cnt_str in + <:module_expr@loc< struct $str_item$ end >> + +let () = + (* <:type_conv< type t = ... >> outputs the generated code but discards the type definition *) + Quotation.add "type_conv" Quotation.DynAst.module_expr_tag type_conv_quotation + +(* Record field defaults *) + +(* Add "default" to set of record field generators *) +let () = + add_record_field_generator_with_arg "default" Syntax.expr + (fun expr_opt tp -> + let loc = Ast.loc_of_ctyp tp in + let default = + match expr_opt with + | Some expr -> expr + | None -> Loc.raise loc (Failure "could not parse default expression") + in + if Hashtbl.mem Gen.record_defaults loc then + Loc.raise loc (Failure "several default expressions are given"); + Hashtbl.replace Gen.record_defaults loc default) + +(* Removal of warnings (in signatures). + Because ocaml gives warnings but doesn't give a way to deactivate them, we have + plenty in the generated code. The most annoyings ones are the ones in signatures, + because they are harder to remove. + For instance: + module M : sig type t = [ `A ] with sexp end = ... + is likely to generate a warning 'unused value t_of_sexp__' in the signature (the same + warning in an implementation would be already removed). + To work around that, every auto generated 'val name : type' is replaced by + 'val name : type _no_unused_value_warning_'. + And in a second step (could probably be done in one step, but it would be complicated), + we try to generate an expression that will use these names (which we recognize because + of the mark), and whether we succeed or not, we remove the mark. + To use a 'val name : type' in a context like: + module M : sig val name : type end = ... + you simply need to do: + let _ = M.name + And there are other tricks depending on where the signature item appear. The removal of + warning doesn't handle all possible ways of generating warnings. *) + +module String_set = Set.Make(String) + +let qualify_idents loc m idents = + List.map (fun i -> <:ident@loc< $uid:m$.$i$ >>) idents +let use_idents loc idents = + List.fold_left + (fun acc i -> <:str_item@loc< $acc$; value _ = $id:i$; >>) + <:str_item@loc< >> idents +let use_idents_in loc idents body = + List.fold_left + (fun acc i -> <:expr@loc< let _ = $id:i$ in $acc$ >>) + body idents + +let ignore = object (self) + inherit Ast.map as super + + method! expr = function + | <:expr@loc< let module $uid:m$ : $module_type$ = $module_expr$ in $body$ >> -> + let module_expr = self#module_expr module_expr in + let idents, module_type = self#ignore_module_type module_type in + let body = self#expr body in + let body = use_idents_in loc (qualify_idents loc m idents) body in + <:expr@loc< let module $uid:m$ : $module_type$ = $module_expr$ in $body$ >> + | expr -> super#expr expr + + method! str_item = function + | <:str_item@loc< module type $s$ = $module_type$ >> -> + let idents, module_type = self#ignore_module_type module_type in + let warnings_removal = use_idents loc (qualify_idents loc s idents) in + if idents = [] + then <:str_item@loc< module type $s$ = $module_type$; >> + else <:str_item@loc< + module type $s$ = $module_type$; + value () = if True then () else begin + let module M($s$ : $uid:s$) = struct + $warnings_removal$; + end in + () + end; + >> + + | <:str_item@loc< module $uid:m$ : $module_type$ = $module_expr$ >> -> + let module_expr = self#module_expr module_expr in + let idents, module_type = self#ignore_module_type module_type in + let warnings_removal = use_idents loc (qualify_idents loc m idents) in + <:str_item@loc< module $uid:m$ : $module_type$ = $module_expr$; $warnings_removal$ >> + + | <:str_item@loc< include ($module_expr$ : $module_type$) >> -> + let module_expr = self#module_expr module_expr in + let idents, module_type = self#ignore_module_type module_type in + let warnings_removal = use_idents loc idents in + <:str_item@loc< include ($module_expr$ : $module_type$); $warnings_removal$ >> + + | StMod _ + | StSem _ + | StInc _ + | StNil _ + | StCls _ + | StClt _ + | StDir _ + | StExc _ + | StExp _ + | StExt _ + | StRecMod _ + | StOpn _ + | StTyp _ + | StVal _ + | StAnt _ as str_item -> + super#str_item str_item + + method fold_map_on_functor_arg warnings_removal = function + | MeFun (loc, s, mt, me) -> + (* wouldn't be quite right if you have a functor that takes several arguments with + the same name, but who would do that anyway? *) + let idents, mt = self#ignore_module_type mt in + let more_warnings_removal = use_idents loc (qualify_idents loc s idents) in + let warnings_removal = <:str_item@loc< $warnings_removal$; $more_warnings_removal$ >> in + let me = self#fold_map_on_functor_arg warnings_removal me in + MeFun (loc, s, mt, me) + | me -> + match self#module_expr me with + | MeStr (loc, str_item) -> + MeStr (loc, <:str_item@loc< $warnings_removal$; $str_item$ >>) + | MeTyc (loc, MeStr (loc2, str_item), mt) -> + MeTyc (loc, MeStr (loc2, <:str_item@loc2< $warnings_removal$; $str_item$ >>), mt) + | me -> + (* not ignoring the warnings in this case because we don't even know if $me$ is + a functor or not, which makes it impossible to find a way of inserting + $warnings_removal$ *) + me + + method! module_expr = function + | MeFun (loc, _, _, _) as me -> self#fold_map_on_functor_arg <:str_item@loc< >> me + + | MeAtt _ + | MeStr _ + | MeTyc _ + | MeNil _ + | MeId _ + | MePkg _ + | MeAnt _ + | MeApp _ as me -> + super#module_expr me + + (* Strip all the 'markers' that have not been handled *) + method! sig_item = function + | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> + <:sig_item@loc< value $id$ : $ctyp$ >> + | sig_item -> super#sig_item sig_item + + method ignore_module_type = function + | MtAlias _ + | MtAtt _ + | MtNil _ + | MtId _ + | MtFun _ + | MtQuo _ + | MtOf _ + | MtAnt _ as mt -> + [], self#module_type mt + | MtSig (loc, sig_item) -> + let idents, sig_item = self#ignore_sig_item sig_item in + idents, MtSig (loc, sig_item) + | MtWit (loc, module_type, with_constr) -> + let idents, module_type = self#ignore_module_type module_type in + idents, MtWit (loc, module_type, with_constr) + + method ignore_sig_item sig_item = + let next_defs = String_set.empty in + let _next_defs, acc, sig_item = self#ignore_sig_item_aux next_defs [] sig_item in + acc, sig_item + method ignore_sig_item_aux next_defs acc = function + | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> + if String_set.mem id next_defs then + next_defs, acc, <:sig_item@loc< >> + else + let next_defs = String_set.add id next_defs in + let sig_item = <:sig_item@loc< value $id$ : $self#ctyp ctyp$ >> in + next_defs, <:ident@loc< $lid:id$ >> :: acc, sig_item + | <:sig_item< value $id$ : $_$ >> as sig_item -> + let sig_item = self#sig_item sig_item in + let next_defs = String_set.add id next_defs in + next_defs, acc, sig_item + | <:sig_item@loc< module $uid:m$ : $module_type$ >> -> + let new_idents, module_type = self#ignore_module_type module_type in + next_defs, acc @ qualify_idents loc m new_idents, <:sig_item@loc< module $uid:m$ : $module_type$ >> + | <:sig_item@loc< $si1$; $si2$ >> -> + (* in here, we are traversing from right to left, so that when see an identifier + we already know whether a further 'val ...' will hide it *) + let next_defs, acc, si2 = self#ignore_sig_item_aux next_defs acc si2 in + let next_defs, acc, si1 = self#ignore_sig_item_aux next_defs acc si1 in + next_defs, acc, <:sig_item@loc< $si1$; $si2$ >> + | sig_item -> next_defs, acc, self#sig_item sig_item +end + +let strip = object + inherit Ast.map as super + + method! sig_item = function + | <:sig_item@loc< value $id$ : _no_unused_value_warning_ $ctyp$ >> -> + <:sig_item@loc< value $id$ : $ctyp$ >> + | sig_item -> super#sig_item sig_item +end + +let () = + (* above, the parser used 'sig' and 'end' as anchors but an mli is a signature + without the sig and end. So here we catch all the elements that have been inserted + at toplevel in the mli *) + let _, current_sig_parser = Register.current_parser () in + Register.register_sig_item_parser (fun ?directive_handler _loc stream -> + let mli = current_sig_parser ?directive_handler _loc stream in + match Signature_stack.Item.delayed_sigs Signature_stack.bottom with + | [] -> mli + | sig_items -> <:sig_item< $list: mli :: sig_items$ >> + ); + AstFilters.register_sig_item_filter strip#sig_item; + AstFilters.register_str_item_filter ignore#str_item; + AstFilters.register_topphrase_filter ignore#str_item diff -Nru type-conv-111.13.00/src/pa_type_conv.mldylib type-conv-113.00.02/src/pa_type_conv.mldylib --- type-conv-111.13.00/src/pa_type_conv.mldylib 1970-01-01 00:00:00.000000000 +0000 +++ type-conv-113.00.02/src/pa_type_conv.mldylib 2015-09-24 18:04:37.000000000 +0000 @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 4688111c934ddd0f4ac3eded6942b27f) +Pa_type_conv +# OASIS_STOP diff -Nru type-conv-111.13.00/src/pa_type_conv.mli type-conv-113.00.02/src/pa_type_conv.mli --- type-conv-111.13.00/src/pa_type_conv.mli 1970-01-01 00:00:00.000000000 +0000 +++ type-conv-113.00.02/src/pa_type_conv.mli 2015-09-24 18:04:37.000000000 +0000 @@ -0,0 +1,271 @@ +(** Pa_type_conv: Preprocessing Module for Registering Type Conversions *) + +open Camlp4.PreCast.Ast + +(** {6 Generator registration} *) + +val set_conv_path_if_not_set : Loc.t -> unit +(** [set_conv_path_if_not_set loc] sets the path to the file/module being + converted for improved error messages. *) + +val get_conv_path : unit -> string +(** [get_conv_path ()] @return the name to module containing a type + as required for error messages. *) + +val add_generator : ?is_exn : bool -> string -> (bool -> ctyp -> str_item) -> unit +(** [add_generator ?is_exn name gen] adds the code generator [gen], + which maps type or exception declarations to structure items, where + [is_exn] specifies whether the declaration is an exception. Note that + the original type/exception declarations get added automatically in + any case. + + @param is_exn = [false] +*) + +val add_generator_with_arg : + ?is_exn : bool -> string -> 'a Camlp4.PreCast.Gram.Entry.t -> + ('a option -> bool -> ctyp -> str_item) -> unit +(** [add_generator_with_arg ?is_exn name entry generator] same as + [add_generator], but the generator may accept an argument, which is + parsed with [entry]. *) + +val rm_generator : ?is_exn : bool -> string -> unit +(** [rm_generator ?is_exn name] removes the code generator named [name] + for types if [is_exn] is [false], or exceptions otherwise. + + @param is_exn = [false] +*) + +val add_sig_generator : + ?delayed : bool -> ?is_exn : bool -> + string -> (bool -> ctyp -> sig_item) -> unit +(** [add_sig_generator ?delayed ?is_exn name gen] adds the code generator [gen], + which maps type or exception declarations to signature items, where + [is_exn] specifies whether the declaration is an exception. Note that the + original type/exception declarations get added automatically in any case. If + [delayed] is set to true, the output of this generator is appended to the + signature in which it's defined + + @param delayed = [false] + @param is_exn = [false] +*) + +val add_sig_generator_with_arg : + ?delayed : bool -> ?is_exn : bool -> string -> + 'a Camlp4.PreCast.Gram.Entry.t -> + ('a option -> bool -> ctyp -> sig_item) -> unit +(** [add_sig_generator_with_arg ?delayed ?is_exn name entry generator] same as + [add_sig_generator], but the generator may accept an argument, + which is parsed with [entry]. *) + +val rm_sig_generator : ?is_exn : bool -> string -> unit +(** [rm_sig_generator ?is_exn name] removes the signature code generator named + [name] for types if [is_exn] is [false], or exceptions otherwise. + + @param is_exn = [false] +*) + +(** Type of record field code generators *) +type record_field_generator = ctyp -> unit + +val add_record_field_generator : string -> record_field_generator -> unit +(** [add_record_field_generator gen_name gen] adds the record field code + generator [gen] with name [gen_name], which acts on the location + identifying the record field. *) + +val add_record_field_generator_with_arg : + string -> 'a Camlp4.PreCast.Gram.Entry.t -> + ('a option -> record_field_generator) -> unit +(** [add_record_field_generator_with_arg name entry generator] same as + [add_record_field_generator], but the [generator] takes an argument, + which is parsed with [entry]. If [None] is passed to the generator, + parsing of the argument failed, otherwise [Some arg] will be passed, + where [arg] is the successfully parsed argument. *) + +val rm_record_field_generator : string -> unit +(** [rm_record_field_generator name] removes the record field code generator + named [name]. *) + +(** {6 Generator sets registration} *) + +val add_sig_set : ?is_exn: bool -> string -> set: string list -> unit +(** [add_sig_set ?is_exn id ~set] adds the generator [id] to the list + of generators for signatures. + This generator will behave as if is all the generators from [set] + had been given instead. Any duplicate arising from repeatedly + expanding such generators are removed. + If [is_exn], then it is a generator for exception declaration, or + else it is a generator for type declaration. +*) + +val add_str_set : ?is_exn: bool -> string -> set: string list -> unit +(** [add_str_set ?is_exn id ~set] behaves exactly like + [add_sig_set ?is_exn id ~set] but for structure items instead of + signatures items. +*) + +val add_set : + kind:[`Str | `Sig | `Both] -> + is_exn:[`Yes | `No | `Both] -> + string -> + set:string list -> + unit +(** [add_set ~kind ~is_exn id ~set] is a shorthand for doing multiple + calls to [add_str_set] and [add_sig_set] +*) + +(** {6 Utility functions} *) + +val get_loc_err : Loc.t -> string -> string +(** [get_loc_err loc msg] generates a compile-time error message. *) + +val hash_variant : string -> int +(** [hash_variant str] @return the integer encoding a variant tag with + name [str]. *) + + +(** {6 General purpose code generation module} *) + +module Gen : sig + + (* For use in messages etc. *) + val string_of_ctyp : ctyp -> string + + val regular_constr_of_revised_constr : string -> string + (* Transforms names of constructor of sum types (including polymorphic variants) from + their revised representation in the camlp4 ast to the representation they would + have in ocaml's ast. + + This is supposed to be used like this: + match ctyp with + | <:ctyp< $uid:constr$ >> -> + <:expr< $str:regular_constr_of_revised_constr constr$ >> + | _ -> ... + + so that <:ctyp< True >> becomes "true" and <:ctyp< True >> (assuming regular + ocaml in the quotation) becomes "True" and not " True". + + Everything also applies to exception names. *) + + val exApp_of_list : expr list -> expr + (** [expr_app_of_list l] takes list [l] of expressions [e1; e2; e3; ...] + and returns the expression [e1 e2 e3]. C.f.: [Ast.exSem_of_list]. *) + + val tyArr_of_list : ctyp list -> ctyp + (** [tyArr_of_list l] takes list [l] of types [e1; e2; e3; ...] and + returns the type [e1 -> e2 -> e3]. C.f.: [Ast.exSem_of_list]. *) + + val paOr_of_list : patt list -> patt + (** [paOr_of_list l] takes list [l] of patterns [p1; p2; p3; ...] and returns + the pattern [p1 | p2 | p3 | ...] *) + + val gensym : ?prefix : string -> unit -> string + (** [gensym ?prefix ()] generates a fresh variable name with [prefix]. + When used with the default parameters, it will return: [_x__001], + [_x__002], [_x__003], ... + + @param prefix default = "_x" + *) + + val error : ctyp -> fn : string -> msg : string -> _ + (** [error tp ~fn ~msg] raises an error with [msg] on type [tp] occuring + in function [fn]. *) + + val unknown_type : ctyp -> string -> _ + (** [unknown_type tp fn] type [tp] cannot be handled by function [fn]. *) + + val ty_var_list_of_ctyp : ctyp -> string list -> string list + (** [ty_var_list_of_ctyp tp acc] accumulates a list of type parameters + contained in [tp] into [acc] as strings. *) + + val get_rev_id_path : ident -> string list -> string list + (** [get_rev_id_path id acc] takes an identifier. @return a reversed + module path (list of strings) denoting this identifier, appending + it to [acc]. *) + + val ident_of_rev_path : Loc.t -> string list -> ident + (** [ident_of_rev_path loc path] takes a location [loc] and a reversed path + [rev_path] to an identifier. @return identifier denoting the + bound value. *) + + val get_appl_path : Loc.t -> ctyp -> ident + (** [get_appl_path loc tp] @return the identifier path associated with + a polymorphic type. *) + + val abstract : Loc.t -> patt list -> expr -> expr + (** [abstract loc patts body] takes a location [loc], a pattern list + [patts], and an expression [body]. @return a function expression + that takes the patterns as arguments, and binds them in [body]. *) + + val apply : Loc.t -> expr -> expr list -> expr + (** [apply loc f_expr arg_exprs] takes a location [loc], an expression + [f_expr] representing a function, and a list of argument expressions + [arg_exprs]. @return an expression in which the function is + applied to its arguments. *) + + val switch_tp_def : + alias : (Loc.t -> ctyp -> 'a) -> + sum : (Loc.t -> ctyp -> 'a) -> + record : (Loc.t -> ctyp -> 'a) -> + variants : (Loc.t -> ctyp -> 'a) -> + mani : (Loc.t -> ctyp -> ctyp -> 'a) -> + nil : (Loc.t -> 'a) -> + ctyp + -> 'a + (** [switch_tp_def ~alias ~sum ~record ~variants ~mani tp_def] + takes a handler function for each kind of type definition and + applies the appropriate handler when [tp_def] matches. *) + + val mk_expr_lst : Loc.t -> expr list -> expr + (** [mk_expr_lst loc expr_list] takes a list of expressions. + @return an expression representing a list of expressions. *) + + val mk_patt_lst : Loc.t -> patt list -> patt + (** [mk_patt_lst _loc patt_list] takes a list of patterns. + @return a pattern representing a list of patterns. *) + + val get_tparam_id : ctyp -> string + (** [get_tparam_id tp] @return the string identifier associated with + [tp] if it is a type parameter. @raise Failure otherwise. *) + + val type_is_recursive : + ?stop_on_functions:bool -> + ?short_circuit:(ctyp -> bool option) -> + string -> ctyp -> bool + (** [type_is_recursive ?short_circuit id tp] + @return whether the type [tp] with name [id] + refers to itself, assuming that it is not mutually recursive with + another type. + + @param short_circuit allows you to override the search for certain + type expressions. + @param stop_on_functions allows to disregard the recursive occurences appearing in + arrow types. The default is to disregard them. + *) + + val drop_variance_annotations : ctyp -> ctyp + (** [drop_variance_annotations tp] @return the type resulting from dropping + all variance annotations in [tp]. *) + + val find_record_default : Loc.t -> expr option + (** [find_record_default loc] @return the optional default expression + associated with the record field at source location [loc] if defined. *) + + val delay_sig_item : sig_item -> unit + (** [delay_sig_item item] places [item] at the end of the current signature *) +end + +(** {6 Utility functions to rewrite type definitions} *) + +module Rewrite_tds : sig + val sig_ : Loc.t -> bool -> ctyp -> sig_item + (** [sig_ loc rec_ typedefs] rewrites the given type definition to make it either + recursive or non recursive. + For instance, the parser calls [sig_ loc false (TyDcl (_, t, [], t, []))] when it + encouters [type t = t] and calls [sig_ loc true (TyDcl (_, t, [], t, []))] when it + encouters [type nonrec t = t] in signatures. *) + + val str_ : Loc.t -> bool -> ctyp -> str_item + (** [str_ loc rec_ typedefs] does the same thing as [sig_ loc rec_ typedefs], except + that it returns a structure item instead of a signature item. *) +end diff -Nru type-conv-111.13.00/src/pa_type_conv.mllib type-conv-113.00.02/src/pa_type_conv.mllib --- type-conv-111.13.00/src/pa_type_conv.mllib 1970-01-01 00:00:00.000000000 +0000 +++ type-conv-113.00.02/src/pa_type_conv.mllib 2015-09-24 18:04:37.000000000 +0000 @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 4688111c934ddd0f4ac3eded6942b27f) +Pa_type_conv +# OASIS_STOP diff -Nru type-conv-111.13.00/_tags type-conv-113.00.02/_tags --- type-conv-111.13.00/_tags 2014-05-12 10:09:05.000000000 +0000 +++ type-conv-113.00.02/_tags 2015-09-24 18:04:37.000000000 +0000 @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: 4b9cb53c8f3f8f5baad9d5caf463ddfc) +# DO NOT EDIT (digest: 9d17a15e1b1dc93f7b9bcb4a2ca23283) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process +true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse @@ -14,8 +15,8 @@ "_darcs": -traverse "_darcs": not_hygienic # Library pa_type_conv -"lib/pa_type_conv.cmxs": use_pa_type_conv -: package(camlp4.quotations) -: package(camlp4.extend) +"src/pa_type_conv.cmxs": use_pa_type_conv +: package(camlp4.extend) +: package(camlp4.quotations) # OASIS_STOP -: syntax_camlp4o +: syntax_camlp4o