[Pkg-ocaml-maint-commits] [ppx-tools] 02/09: Imported Upstream version 5.0+4.02.0
Stéphane Glondu
glondu at moszumanska.debian.org
Wed Jul 27 10:40:50 UTC 2016
This is an automated email from the git hooks/post-receive script.
glondu pushed a commit to branch master
in repository ppx-tools.
commit 00c032bc2513fbeb1d17bba3ab58ef21f4267fe7
Author: Stephane Glondu <steph at glondu.net>
Date: Wed Jul 27 12:22:58 2016 +0200
Imported Upstream version 5.0+4.02.0
---
META | 4 +--
Makefile | 2 +-
README.md | 5 ----
ast_convenience.ml | 81 ++++++++++++++++++++++++++++++++++++----------------
ast_convenience.mli | 22 +++++++-------
ast_mapper_class.ml | 17 +++--------
ast_mapper_class.mli | 1 -
dumpast.ml | 2 +-
genlifter.ml | 36 +++++++++--------------
opam | 2 +-
ppx_metaquot.ml | 12 ++++----
11 files changed, 97 insertions(+), 87 deletions(-)
diff --git a/META b/META
index 026c3bb..552edd7 100644
--- a/META
+++ b/META
@@ -1,11 +1,11 @@
-version = "5.0"
+version = "5.0+4.0.2"
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"
+ version = "5.0+4.0.2"
description = "Meta-quotation: Parsetree manipulation using concrete syntax"
requires = "ppx_tools"
ppx = "./ppx_metaquot"
diff --git a/Makefile b/Makefile
index 254d6cc..f27829a 100644
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,7 @@
include $(shell ocamlc -where)/Makefile.config
PACKAGE = ppx_tools
-VERSION = 5.0
+VERSION = 5.0+4.02.2
# Don't forget to change META file as well
OCAMLC = ocamlc -bin-annot
diff --git a/README.md b/README.md
index a75fbf0..8770204 100644
--- a/README.md
+++ b/README.md
@@ -9,11 +9,6 @@ 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 7d73bf8..1dcca3d 100644
--- a/ast_convenience.ml
+++ b/ast_convenience.ml
@@ -10,33 +10,66 @@ open Ast_helper
module Label = struct
- type t = Asttypes.arg_label
+ type t = string
- type desc = Asttypes.arg_label =
+ type desc =
Nolabel
| Labelled of string
| Optional of string
- let explode x = x
+ 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 nolabel = Nolabel
- let labelled x = Labelled x
- let optional x = Optional x
+ let nolabel = ""
+ let labelled s = s
+ let optional s = "?"^s
end
module Constant = struct
- type t = Parsetree.constant =
+ type t =
Pconst_integer of string * char option
| Pconst_char of char
| Pconst_string of string * string option
- | Pconst_float of string * char option
-
- let of_constant x = x
-
- let to_constant x = x
-
-end
+ | 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
let may_tuple ?loc tup = function
| [] -> None
@@ -53,10 +86,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 (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 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 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)
@@ -83,19 +116,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 (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 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 tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l
let get_str = function
- | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s
+ | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s
| _ -> None
let get_str_with_quotation_delimiter = function
- | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d)
+ | {pexp_desc=Pexp_constant (Const_string (s, d)); _} -> Some (s, d)
| _ -> None
let get_lid = function
diff --git a/ast_convenience.mli b/ast_convenience.mli
index fd6246b..afc9d0a 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 = Asttypes.arg_label
+ type t = string
- type desc = Asttypes.arg_label =
+ type desc =
Nolabel
| Labelled of string
| Optional of string
@@ -26,21 +26,21 @@ module Label : sig
end
-(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant
- * types defined in ocaml 4.03 and 4.02 respectively}*)
+(** {2 Provides abstraction over Asttypes.constant type }*)
module Constant : sig
- type t = Parsetree.constant =
+ type t =
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
- (** Convert Constant.t to Asttypes.constant *)
- val to_constant : t -> Parsetree.constant
+ exception Unknown_literal of string * char
+
+ (** Converts Asttypes.constant to Constant.t *)
+ val of_constant : constant -> t
+ (** 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 bec303a..b3a666a 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(sub # constructor_arguments ctl, map_opt (sub # typ) cto)
+ Pext_decl(List.map (sub # typ) 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 (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l)
+ | Psig_type l -> type_ ~loc (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 (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l)
+ | Pstr_type l -> type_ ~loc (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)
@@ -293,10 +293,6 @@ module E = struct
| Pexp_letmodule (s, me, e) ->
letmodule ~loc ~attrs (map_loc sub s) (sub # module_expr me)
(sub # expr e)
- | Pexp_letexception (cd, e) ->
- letexception ~loc ~attrs
- (sub # extension_constructor cd)
- (sub # expr e)
| Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e)
| Pexp_lazy e -> lazy_ ~loc ~attrs (sub # expr e)
| Pexp_poly (e, t) ->
@@ -307,7 +303,6 @@ 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
@@ -474,15 +469,12 @@ 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:(this # constructor_arguments pcd_args)
+ ~args:(List.map (this # typ) pcd_args)
?res:(map_opt (this # typ) pcd_res)
~loc:(this # location pcd_loc)
~attrs:(this # attributes pcd_attributes)
@@ -533,7 +525,6 @@ 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 4456d53..e6d3be2 100644
--- a/ast_mapper_class.mli
+++ b/ast_mapper_class.mli
@@ -21,7 +21,6 @@ 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 989be41..be394c4 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 fn);
+ Compenv.readenv Format.err_formatter Compenv.Before_compile;
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 a3eae47..b238823 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 Nolabel (var "a") (var "res"))))
+ (virtual_ Typ.(poly ["a"] (arrow "" (var "a") (var "res"))))
)
let arrow_method =
Cf.(method_ (mknoloc "arrow") Public
- (virtual_ Typ.(poly ["a"] (arrow Nolabel (var "a") (var "res"))))
+ (virtual_ Typ.(poly ["a"] (arrow "" (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 Asttypes.Nolabel (constr (lid ty) tyargs) (var "res")) in
+ let make_result_t tyargs = Typ.(arrow "" (constr (lid ty) tyargs) (var "res")) in
let make_t tyargs =
List.fold_right
(fun arg t ->
- Typ.(arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg (var "res")) t))
+ Typ.(arrow "" (arrow "" 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,15 +98,8 @@ module Main : sig end = struct
let case cd =
let c = Ident.name cd.cd_id in
let qc = prefix ^ c in
- 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)]]]
+ let p, args = gentuple env cd.cd_args in
+ pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]]
in
concrete (func (List.map case l))
| Type_abstract, Some t ->
@@ -175,14 +168,13 @@ module Main : sig end = struct
let open Parsetree in
match e.pexp_desc with
| Pexp_fun
- (Asttypes.Nolabel, None,
+ ("", None,
{ppat_desc = Ppat_var{txt=id;_};_},
{pexp_desc =
Pexp_apply
(f,
- [Asttypes.Nolabel
- ,{pexp_desc= Pexp_ident{txt=Lident id2;_};_}]);_})
- when id = id2 -> f
+ ["",{pexp_desc=
+ Pexp_ident{txt=Lident id2;_};_}]);_}) when id = id2 -> f
| _ -> e
in
{super with expr}
diff --git a/opam b/opam
index c3c546a..19973e4 100644
--- a/opam
+++ b/opam
@@ -12,4 +12,4 @@ remove: [["ocamlfind" "remove" "ppx_tools"]]
depends: [
"ocamlfind" {>= "1.5.0"}
]
-available: ocaml-version >= "4.03.0"
+available: ocaml-version >= "4.02.0" & ocaml-version < "4.03.0"
diff --git a/ppx_metaquot.ml b/ppx_metaquot.ml
index 750e9e8..401b1d5 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