This is an automated email from the git hooks/post-receive script. glondu pushed a commit to branch master in repository ppx-tools.
commit 1642d7682b90f9e7e1889c3f753d67234bb94bd6 Author: Stephane Glondu <[email protected]> Date: Wed Jul 19 18:59:35 2017 +0200 New upstream version 5.0+4.03.0 --- META | 4 +-- Makefile | 2 +- README.md | 5 ++++ ast_convenience.ml | 81 ++++++++++++++++------------------------------------ ast_convenience.mli | 22 +++++++------- ast_mapper_class.ml | 13 ++++++--- ast_mapper_class.mli | 1 + dumpast.ml | 2 +- genlifter.ml | 36 ++++++++++++++--------- opam | 2 +- ppx_metaquot.ml | 12 ++++---- 11 files changed, 83 insertions(+), 97 deletions(-) diff --git a/META b/META index 552edd7..026c3bb 100644 --- a/META +++ b/META @@ -1,11 +1,11 @@ -version = "5.0+4.0.2" +version = "5.0" description = "Tools for authors of ppx rewriters and other syntactic tools" archive(byte) = "ppx_tools.cma" archive(native) = "ppx_tools.cmxa" requires = "compiler-libs.common" package "metaquot" ( - version = "5.0+4.0.2" + version = "5.0" description = "Meta-quotation: Parsetree manipulation using concrete syntax" requires = "ppx_tools" ppx = "./ppx_metaquot" diff --git a/Makefile b/Makefile index f27829a..254d6cc 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ include $(shell ocamlc -where)/Makefile.config PACKAGE = ppx_tools -VERSION = 5.0+4.02.2 +VERSION = 5.0 # Don't forget to change META file as well OCAMLC = ocamlc -bin-annot diff --git a/README.md b/README.md index 8770204..a75fbf0 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,11 @@ The tools are installed as a findlib package called 'ppx_tools'. Executables are thus accessible through the ocamlfind driver (e.g.: ocamlfind ppx_tools/dumpast). +Main contributors: + + - Alain Frisch + - Peter Zotov (whitequark) + - Gabriel Radanne (Drup) ppx_metaquot ------------ diff --git a/ast_convenience.ml b/ast_convenience.ml index 1dcca3d..7d73bf8 100644 --- a/ast_convenience.ml +++ b/ast_convenience.ml @@ -10,66 +10,33 @@ open Ast_helper module Label = struct - type t = string + type t = Asttypes.arg_label - type desc = + type desc = Asttypes.arg_label = Nolabel | Labelled of string | Optional of string - let explode s = - if s = "" then Nolabel - else if s.[0] = '?' then Optional (String.sub s 1 (String.length s - 1)) - else Labelled s + let explode x = x - let nolabel = "" - let labelled s = s - let optional s = "?"^s + let nolabel = Nolabel + let labelled x = Labelled x + let optional x = Optional x end module Constant = struct - type t = + type t = Parsetree.constant = Pconst_integer of string * char option | Pconst_char of char | Pconst_string of string * string option - | Pconst_float of string * char option - - exception Unknown_literal of string * char - - (** Backport Int_literal_converter from ocaml 4.03 - - * https://github.com/ocaml/ocaml/blob/trunk/utils/misc.ml#L298 *) - module Int_literal_converter = struct - let cvt_int_aux str neg of_string = - if String.length str = 0 || str.[0] = '-' - then of_string str - else neg (of_string ("-" ^ str)) - let int s = cvt_int_aux s (~-) int_of_string - let int32 s = cvt_int_aux s Int32.neg Int32.of_string - let int64 s = cvt_int_aux s Int64.neg Int64.of_string - let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string - end - - let of_constant = function - | Asttypes.Const_int32(i) -> Pconst_integer(Int32.to_string i, Some 'l') - | Asttypes.Const_int64(i) -> Pconst_integer(Int64.to_string i, Some 'L') - | Asttypes.Const_nativeint(i) -> Pconst_integer(Nativeint.to_string i, Some 'n') - | Asttypes.Const_int(i) -> Pconst_integer(string_of_int i, None) - | Asttypes.Const_char c -> Pconst_char c - | Asttypes.Const_string(s, s_opt) -> Pconst_string(s, s_opt) - | Asttypes.Const_float f -> Pconst_float(f, None) - - let to_constant = function - | Pconst_integer(i,Some 'l') -> Asttypes.Const_int32 (Int_literal_converter.int32 i) - | Pconst_integer(i,Some 'L') -> Asttypes.Const_int64 (Int_literal_converter.int64 i) - | Pconst_integer(i,Some 'n') -> Asttypes.Const_nativeint (Int_literal_converter.nativeint i) - | Pconst_integer(i,None) -> Asttypes.Const_int (Int_literal_converter.int i) - | Pconst_integer(i,Some c) -> raise (Unknown_literal (i, c)) - | Pconst_char c -> Asttypes.Const_char c - | Pconst_string(s,d) -> Asttypes.Const_string(s, d) - | Pconst_float(f,None) -> Asttypes.Const_float f - | Pconst_float(f,Some c) -> raise (Unknown_literal (f, c)) -end + | Pconst_float of string * char option + + let of_constant x = x + + let to_constant x = x + +end let may_tuple ?loc tup = function | [] -> None @@ -86,10 +53,10 @@ let tuple ?loc ?attrs = function | xs -> Exp.tuple ?loc ?attrs xs let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) -let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Const_string (s, None)) -let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_int x) -let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_char x) -let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_float (string_of_float x)) +let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) +let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) +let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) let record ?loc ?attrs ?over l = Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) @@ -116,19 +83,19 @@ let ptuple ?loc ?attrs = function | xs -> Pat.tuple ?loc ?attrs xs let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) -let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Const_string (s, None)) -let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_int x) -let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_char x) -let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_float (string_of_float x)) +let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) +let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) +let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l let get_str = function - | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s + | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s | _ -> None let get_str_with_quotation_delimiter = function - | {pexp_desc=Pexp_constant (Const_string (s, d)); _} -> Some (s, d) + | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) | _ -> None let get_lid = function diff --git a/ast_convenience.mli b/ast_convenience.mli index afc9d0a..fd6246b 100644 --- a/ast_convenience.mli +++ b/ast_convenience.mli @@ -4,16 +4,16 @@ (** {1 Convenience functions to help build and deconstruct AST fragments.} *) -open Parsetree open Asttypes open Ast_helper +open Parsetree (** {2 Compatibility modules} *) module Label : sig - type t = string + type t = Asttypes.arg_label - type desc = + type desc = Asttypes.arg_label = Nolabel | Labelled of string | Optional of string @@ -26,21 +26,21 @@ module Label : sig end -(** {2 Provides abstraction over Asttypes.constant type }*) +(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant + * types defined in ocaml 4.03 and 4.02 respectively}*) module Constant : sig - type t = + type t = Parsetree.constant = Pconst_integer of string * char option | Pconst_char of char | Pconst_string of string * string option | Pconst_float of string * char option + + (** Convert Asttypes.constant to Constant.t *) + val of_constant : Parsetree.constant -> t - exception Unknown_literal of string * char - - (** Converts Asttypes.constant to Constant.t *) - val of_constant : constant -> t + (** Convert Constant.t to Asttypes.constant *) + val to_constant : t -> Parsetree.constant - (** Converts Constant.t to Asttypes.constant. Raises Unknown_literal if conversion fails *) - val to_constant : t -> constant end (** {2 Misc} *) diff --git a/ast_mapper_class.ml b/ast_mapper_class.ml index b3a666a..0f91ab4 100644 --- a/ast_mapper_class.ml +++ b/ast_mapper_class.ml @@ -88,7 +88,7 @@ module T = struct let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> - Pext_decl(List.map (sub # typ) ctl, map_opt (sub # typ) cto) + Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) | Pext_rebind li -> Pext_rebind (map_loc sub li) @@ -174,7 +174,7 @@ module MT = struct let loc = sub # location loc in match desc with | Psig_value vd -> value ~loc (sub # value_description vd) - | Psig_type l -> type_ ~loc (List.map (sub # type_declaration) l) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) | Psig_typext te -> type_extension ~loc (sub # type_extension te) | Psig_exception ed -> exception_ ~loc (sub # extension_constructor ed) | Psig_module x -> module_ ~loc (sub # module_declaration x) @@ -221,7 +221,7 @@ module M = struct eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) - | Pstr_type l -> type_ ~loc (List.map (sub # type_declaration) l) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) | Pstr_typext te -> type_extension ~loc (sub # type_extension te) | Pstr_exception ed -> exception_ ~loc (sub # extension_constructor ed) | Pstr_module x -> module_ ~loc (sub # module_binding x) @@ -303,6 +303,7 @@ module E = struct | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub # expr e) | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) + | Pexp_unreachable -> unreachable ~loc ~attrs () end module P = struct @@ -469,12 +470,15 @@ class mapper = ~attrs:(this # attributes pvb_attributes) ~loc:(this # location pvb_loc) + method constructor_arguments = function + | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys) + | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls) method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = Type.constructor (map_loc this pcd_name) - ~args:(List.map (this # typ) pcd_args) + ~args:(this # constructor_arguments pcd_args) ?res:(map_opt (this # typ) pcd_res) ~loc:(this # location pcd_loc) ~attrs:(this # attributes pcd_attributes) @@ -525,6 +529,7 @@ class mapper = | PStr x -> PStr (this # structure x) | PTyp x -> PTyp (this # typ x) | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) + | PSig x -> PSig (this # signature x) end diff --git a/ast_mapper_class.mli b/ast_mapper_class.mli index e6d3be2..4456d53 100644 --- a/ast_mapper_class.mli +++ b/ast_mapper_class.mli @@ -21,6 +21,7 @@ class mapper: method class_type: class_type -> class_type method class_type_declaration: class_type_declaration -> class_type_declaration method class_type_field: class_type_field -> class_type_field + method constructor_arguments: constructor_arguments -> constructor_arguments method constructor_declaration: constructor_declaration -> constructor_declaration method expr: expression -> expression method extension: extension -> extension diff --git a/dumpast.ml b/dumpast.ml index be394c4..989be41 100644 --- a/dumpast.ml +++ b/dumpast.ml @@ -54,7 +54,7 @@ let show_pat = show (lift # lift_Parsetree_pattern) Parse.pattern let show_typ = show (lift # lift_Parsetree_core_type) Parse.core_type let show_file fn = - Compenv.readenv Format.err_formatter Compenv.Before_compile; + Compenv.readenv Format.err_formatter (Compenv.Before_compile fn); let v = if Filename.check_suffix fn ".mli" then let ast = Pparse.parse_interface ~tool_name:"ocamlc" Format.err_formatter fn in diff --git a/genlifter.ml b/genlifter.ml index b238823..a3eae47 100644 --- a/genlifter.ml +++ b/genlifter.ml @@ -38,12 +38,12 @@ module Main : sig end = struct let existential_method = Cf.(method_ (mknoloc "existential") Public - (virtual_ Typ.(poly ["a"] (arrow "" (var "a") (var "res")))) + (virtual_ Typ.(poly ["a"] (arrow Nolabel (var "a") (var "res")))) ) let arrow_method = Cf.(method_ (mknoloc "arrow") Public - (virtual_ Typ.(poly ["a"] (arrow "" (var "a") (var "res")))) + (virtual_ Typ.(poly ["a"] (arrow Nolabel (var "a") (var "res")))) ) let rec gen ty = @@ -65,11 +65,11 @@ module Main : sig end = struct Hashtbl.add printed ty (); let params = List.mapi (fun i _ -> Printf.sprintf "f%i" i) td.type_params in let env = List.map2 (fun s t -> t.id, evar s) params td.type_params in - let make_result_t tyargs = Typ.(arrow "" (constr (lid ty) tyargs) (var "res")) in + let make_result_t tyargs = Typ.(arrow Asttypes.Nolabel (constr (lid ty) tyargs) (var "res")) in let make_t tyargs = List.fold_right (fun arg t -> - Typ.(arrow "" (arrow "" arg (var "res")) t)) + Typ.(arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg (var "res")) t)) tyargs (make_result_t tyargs) in let tyargs = List.map (fun t -> Typ.var t) params in @@ -82,13 +82,13 @@ module Main : sig end = struct let body = Exp.poly e (Some t) in meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths in + let field ld = + let s = Ident.name ld.ld_id in + (lid (prefix ^ s), pvar s), + tuple[str s; tyexpr env ld.ld_type (evar s)] + in match td.type_kind, td.type_manifest with | Type_record (l, _), _ -> - let field ld = - let s = Ident.name ld.ld_id in - (lid (prefix ^ s), pvar s), - tuple[str s; tyexpr env ld.ld_type (evar s)] - in let l = List.map field l in concrete (lam @@ -98,8 +98,15 @@ module Main : sig end = struct let case cd = let c = Ident.name cd.cd_id in let qc = prefix ^ c in - let p, args = gentuple env cd.cd_args in - pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] + match cd.cd_args with + | Cstr_tuple (tys) -> + let p, args = gentuple env tys in + pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] + | Cstr_record (l) -> + let l = List.map field l in + pconstr qc [Pat.record (List.map fst l) Closed], + selfcall "constr" [str ty; tuple [str c; + selfcall "record" [str (ty ^ "." ^ c); list (List.map snd l)]]] in concrete (func (List.map case l)) | Type_abstract, Some t -> @@ -168,13 +175,14 @@ module Main : sig end = struct let open Parsetree in match e.pexp_desc with | Pexp_fun - ("", None, + (Asttypes.Nolabel, None, {ppat_desc = Ppat_var{txt=id;_};_}, {pexp_desc = Pexp_apply (f, - ["",{pexp_desc= - Pexp_ident{txt=Lident id2;_};_}]);_}) when id = id2 -> f + [Asttypes.Nolabel + ,{pexp_desc= Pexp_ident{txt=Lident id2;_};_}]);_}) + when id = id2 -> f | _ -> e in {super with expr} diff --git a/opam b/opam index 19973e4..c3c546a 100644 --- a/opam +++ b/opam @@ -12,4 +12,4 @@ remove: [["ocamlfind" "remove" "ppx_tools"]] depends: [ "ocamlfind" {>= "1.5.0"} ] -available: ocaml-version >= "4.02.0" & ocaml-version < "4.03.0" +available: ocaml-version >= "4.03.0" diff --git a/ppx_metaquot.ml b/ppx_metaquot.ml index 401b1d5..750e9e8 100644 --- a/ppx_metaquot.ml +++ b/ppx_metaquot.ml @@ -76,9 +76,9 @@ module Main : sig end = struct method int i = int i method string s = str s method char c = char c - method int32 x = Exp.constant (Const_int32 x) - method int64 x = Exp.constant (Const_int64 x) - method nativeint x = Exp.constant (Const_nativeint x) + method int32 x = Exp.constant (Const.int32 x) + method int64 x = Exp.constant (Const.int64 x) + method nativeint x = Exp.constant (Const.nativeint x) end class pat_builder = @@ -90,9 +90,9 @@ module Main : sig end = struct method int i = pint i method string s = pstr s method char c = pchar c - method int32 x = Pat.constant (Const_int32 x) - method int64 x = Pat.constant (Const_int64 x) - method nativeint x = Pat.constant (Const_nativeint x) + method int32 x = Pat.constant (Const.int32 x) + method int64 x = Pat.constant (Const.int64 x) + method nativeint x = Pat.constant (Const.nativeint x) end -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/ppx-tools.git _______________________________________________ Pkg-ocaml-maint-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits
