[Pkg-ocaml-maint-commits] [ppx-tools] 01/05: New upstream version 5.0+4.03.0
Stéphane Glondu
glondu at moszumanska.debian.org
Wed Jul 19 17:03:03 UTC 2017
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 <steph at glondu.net>
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
More information about the Pkg-ocaml-maint-commits
mailing list