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 <st...@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

_______________________________________________
Pkg-ocaml-maint-commits mailing list
Pkg-ocaml-maint-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits

Reply via email to