commit: 294b229cd1f177bd30b79d0fa5193c113be7cf96
Author: Alexis Ballier <aballier <AT> gentoo <DOT> org>
AuthorDate: Sun May 1 17:45:23 2016 +0000
Commit: Alexis Ballier <aballier <AT> gentoo <DOT> org>
CommitDate: Tue May 3 09:13:52 2016 +0000
URL: https://gitweb.gentoo.org/repo/gentoo.git/commit/?id=294b229c
dev-ml/ppx_core: fix build with ocaml 4.03
Package-Manager: portage-2.2.28
Signed-off-by: Alexis Ballier <aballier <AT> gentoo.org>
dev-ml/ppx_core/files/oc43.patch | 741 ++++++++++++++++++++++++++++++
dev-ml/ppx_core/ppx_core-113.33.00.ebuild | 6 +-
2 files changed, 746 insertions(+), 1 deletion(-)
diff --git a/dev-ml/ppx_core/files/oc43.patch b/dev-ml/ppx_core/files/oc43.patch
new file mode 100644
index 0000000..d5f961d
--- /dev/null
+++ b/dev-ml/ppx_core/files/oc43.patch
@@ -0,0 +1,741 @@
+diff -uNr ppx_core-113.33.00/_oasis ppx_core-113.33.00+4.03/_oasis
+--- ppx_core-113.33.00/_oasis 2016-03-09 16:44:53.000000000 +0100
++++ ppx_core-113.33.00+4.03/_oasis 2016-03-23 17:20:19.000000000 +0100
+@@ -1,8 +1,8 @@
+ OASISFormat: 0.4
+-OCamlVersion: >= 4.02.3
++OCamlVersion: >= 4.03.0
+ FindlibVersion: >= 1.3.2
+ Name: ppx_core
+-Version: 113.33.00
++Version: 113.33.00+4.03
+ Synopsis: Standard library for ppx rewriters
+ Authors: Jane Street Group, LLC <opensou...@janestreet.com>
+ Copyrights: (C) 2015-2016 Jane Street Group LLC
<opensou...@janestreet.com>
+diff -uNr ppx_core-113.33.00/src/ast_builder.ml
ppx_core-113.33.00+4.03/src/ast_builder.ml
+--- ppx_core-113.33.00/src/ast_builder.ml 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/ast_builder.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -28,21 +28,21 @@
+ ({ txt = "nonrec"; loc }, PStr []) :: td.ptype_attributes }
+ ;;
+
+- let eint ~loc t = pexp_constant ~loc (Const_int t)
+- let echar ~loc t = pexp_constant ~loc (Const_char t)
+- let estring ~loc t = pexp_constant ~loc (Const_string (t, None))
+- let efloat ~loc t = pexp_constant ~loc (Const_float t)
+- let eint32 ~loc t = pexp_constant ~loc (Const_int32 t)
+- let eint64 ~loc t = pexp_constant ~loc (Const_int64 t)
+- let enativeint ~loc t = pexp_constant ~loc (Const_nativeint t)
+-
+- let pint ~loc t = ppat_constant ~loc (Const_int t)
+- let pchar ~loc t = ppat_constant ~loc (Const_char t)
+- let pstring ~loc t = ppat_constant ~loc (Const_string (t, None))
+- let pfloat ~loc t = ppat_constant ~loc (Const_float t)
+- let pint32 ~loc t = ppat_constant ~loc (Const_int32 t)
+- let pint64 ~loc t = ppat_constant ~loc (Const_int64 t)
+- let pnativeint ~loc t = ppat_constant ~loc (Const_nativeint t)
++ let eint ~loc t = pexp_constant ~loc (Pconst_integer (string_of_int t,
None))
++ let echar ~loc t = pexp_constant ~loc (Pconst_char t)
++ let estring ~loc t = pexp_constant ~loc (Pconst_string (t, None))
++ let efloat ~loc t = pexp_constant ~loc (Pconst_float (t, None))
++ let eint32 ~loc t = pexp_constant ~loc (Pconst_integer (Int32.to_string t,
Some 'l'))
++ let eint64 ~loc t = pexp_constant ~loc (Pconst_integer (Int64.to_string t,
Some 'L'))
++ let enativeint ~loc t = pexp_constant ~loc (Pconst_integer
(Nativeint.to_string t, Some 'n'))
++
++ let pint ~loc t = ppat_constant ~loc (Pconst_integer (string_of_int t,
None))
++ let pchar ~loc t = ppat_constant ~loc (Pconst_char t)
++ let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, None))
++ let pfloat ~loc t = ppat_constant ~loc (Pconst_float (t, None))
++ let pint32 ~loc t = ppat_constant ~loc (Pconst_integer (Int32.to_string t,
Some 'l'))
++ let pint64 ~loc t = ppat_constant ~loc (Pconst_integer (Int64.to_string t,
Some 'L'))
++ let pnativeint ~loc t = ppat_constant ~loc (Pconst_integer
(Nativeint.to_string t, Some 'n'))
+
+ let ebool ~loc t = pexp_construct ~loc (Located.lident ~loc (string_of_bool
t)) None
+ let pbool ~loc t = ppat_construct ~loc (Located.lident ~loc (string_of_bool
t)) None
+@@ -77,10 +77,11 @@
+ | _ -> pexp_apply ~loc e el
+ ;;
+
+- let eapply ~loc e el = pexp_apply ~loc e (List.map el ~f:(fun e -> ("", e)))
++ let eapply ~loc e el =
++ pexp_apply ~loc e (List.map el ~f:(fun e -> (Asttypes.Nolabel, e)))
+
+ let eabstract ~loc ps e =
+- List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc "" None p e)
++ List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc Asttypes.Nolabel
None p e)
+ ;;
+
+ let pconstruct cd arg = ppat_construct ~loc:cd.pcd_loc (Located.map_lident
cd.pcd_name) arg
+diff -uNr ppx_core-113.33.00/src/ast_pattern.ml
ppx_core-113.33.00+4.03/src/ast_pattern.ml
+--- ppx_core-113.33.00/src/ast_pattern.ml 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/ast_pattern.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -80,6 +80,13 @@
+
+ let ( >>| ) t f = map t ~f
+
++let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k f
))
++let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f
a )))
++let map2 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f
a b)))
++
++let alt_option some none =
++ alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None)
++
+ let many (T f) = T (fun ctx loc l k ->
+ k (List.map l ~f:(fun x -> f ctx loc x (fun x -> x))))
+ ;;
+@@ -96,25 +103,37 @@
+
+ let ( ^:: ) = cons
+
+-let eint t = pexp_constant (const_int t)
+-let echar t = pexp_constant (const_char t)
+-let estring t = pexp_constant (const_string t drop)
+-let efloat t = pexp_constant (const_float t)
+-let eint32 t = pexp_constant (const_int32 t)
+-let eint64 t = pexp_constant (const_int64 t)
++let echar t = pexp_constant (pconst_char t )
++let estring t = pexp_constant (pconst_string t drop)
++let efloat t = pexp_constant (pconst_float t drop)
++
++let pchar t = ppat_constant (pconst_char t )
++let pstring t = ppat_constant (pconst_string t drop)
++let pfloat t = ppat_constant (pconst_float t drop)
++
++let int' (T f) = T (fun ctx loc x k -> f ctx loc (int_of_string
x) k)
++let int32' (T f) = T (fun ctx loc x k -> f ctx loc (Int32.of_string
x) k)
++let int64' (T f) = T (fun ctx loc x k -> f ctx loc (Int64.of_string
x) k)
++let nativeint' (T f) = T (fun ctx loc x k -> f ctx loc (Nativeint.of_string
x) k)
++
++let const_int t = pconst_integer (int' t) none
++let const_int32 t = pconst_integer (int32' t) (some (char 'l'))
++let const_int64 t = pconst_integer (int64' t) (some (char 'L'))
++let const_nativeint t = pconst_integer (nativeint' t) (some (char 'n'))
++
++let eint t = pexp_constant (const_int t)
++let eint32 t = pexp_constant (const_int32 t)
++let eint64 t = pexp_constant (const_int64 t)
+ let enativeint t = pexp_constant (const_nativeint t)
+
+-let pint t = ppat_constant (const_int t)
+-let pchar t = ppat_constant (const_char t)
+-let pstring t = ppat_constant (const_string t drop)
+-let pfloat t = ppat_constant (const_float t)
+-let pint32 t = ppat_constant (const_int32 t)
+-let pint64 t = ppat_constant (const_int64 t)
++let pint t = ppat_constant (const_int t)
++let pint32 t = ppat_constant (const_int32 t)
++let pint64 t = ppat_constant (const_int64 t)
+ let pnativeint t = ppat_constant (const_nativeint t)
+
+ let single_expr_payload t = pstr (pstr_eval t nil ^:: nil)
+
+-let no_label t = string "" ** t
++let no_label t = (cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel")) ** t
+
+ let attribute (T f1) (T f2) = T (fun ctx loc ((name : _ Location.loc),
payload) k ->
+ let k = f1 ctx name.loc name.txt k in
+diff -uNr ppx_core-113.33.00/src/ast_pattern.mli
ppx_core-113.33.00+4.03/src/ast_pattern.mli
+--- ppx_core-113.33.00/src/ast_pattern.mli 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/ast_pattern.mli 2016-03-23
17:20:19.000000000 +0100
+@@ -115,6 +115,10 @@
+ one. *)
+ val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+
++(** Same as [alt], for the common case where the left-hand-side captures a
value but not
++ the right-hand-side. *)
++val alt_option : ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option ->
'b, 'c) t
++
+ (** Same as [alt] *)
+ val ( ||| ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t
+
+@@ -125,6 +129,10 @@
+ (** Same as [map] *)
+ val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t
+
++val map0 : ('a, 'b, 'c) t -> f: 'v -> ('a, 'v ->
'b, 'c) t
++val map1 : ('a, 'v1 -> 'b, 'c) t -> f:('v1 -> 'v) -> ('a, 'v ->
'b, 'c) t
++val map2 : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v ->
'b, 'c) t
++
+ val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t
+ val many : ('a, 'b -> 'b, 'c) t -> ('a list, 'c list -> 'd, 'd) t
+
+@@ -194,7 +202,7 @@
+
+ val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t
+
+-val no_label : (expression, 'a, 'b) t -> (string * expression, 'a, 'b) t
++val no_label : (expression, 'a, 'b) t -> (Asttypes.arg_label * expression,
'a, 'b) t
+
+ val attribute : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (attribute, 'a,
'c) t
+ val extension : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (attribute, 'a,
'c) t
+diff -uNr ppx_core-113.33.00/src/attribute.ml
ppx_core-113.33.00+4.03/src/attribute.ml
+--- ppx_core-113.33.00/src/attribute.ml 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/attribute.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -15,6 +15,10 @@
+ ; "ocaml.doc"
+ ; "ocaml.text"
+ ; "nonrec"
++ ; "ocaml.noalloc"
++ ; "ocaml.unboxed"
++ ; "ocaml.untagged"
++ ; "ocaml.inline"
+ ]
+ ;;
+
+@@ -74,6 +78,7 @@
+ | Pstr_eval : structure_item t
+ | Pstr_extension : structure_item t
+ | Psig_extension : signature_item t
++ | Row_field : row_field t
+
+ let label_declaration = Label_declaration
+ let constructor_declaration = Constructor_declaration
+@@ -100,6 +105,7 @@
+ let pstr_eval = Pstr_eval
+ let pstr_extension = Pstr_extension
+ let psig_extension = Psig_extension
++ let row_field = Row_field
+
+ let get_pstr_eval st =
+ match st.pstr_desc with
+@@ -116,6 +122,17 @@
+ | Psig_extension (e, l) -> (e, l)
+ | _ -> failwith "Attribute.Context.get_psig_extension"
+
++ module Row_field = struct
++ let get_attrs = function
++ | Rinherit _ -> []
++ | Rtag (_, attrs, _, _) -> attrs
++
++ let set_attrs attrs = function
++ | Rinherit _ -> invalid_arg "Row_field.set_attrs"
++ | Rtag (lbl, _, can_be_constant, params_opts) ->
++ Rtag (lbl, attrs, can_be_constant, params_opts)
++ end
++
+ let get_attributes : type a. a t -> a -> attributes = fun t x ->
+ match t with
+ | Label_declaration -> x.pld_attributes
+@@ -143,6 +160,7 @@
+ | Pstr_eval -> snd (get_pstr_eval x)
+ | Pstr_extension -> snd (get_pstr_extension x)
+ | Psig_extension -> snd (get_psig_extension x)
++ | Row_field -> Row_field.get_attrs x
+
+ let set_attributes : type a. a t -> a -> attributes -> a = fun t x attrs ->
+ match t with
+@@ -174,6 +192,7 @@
+ { x with pstr_desc = Pstr_extension (get_pstr_extension x |> fst,
attrs) }
+ | Psig_extension ->
+ { x with psig_desc = Psig_extension (get_psig_extension x |> fst,
attrs) }
++ | Row_field -> Row_field.set_attrs attrs x
+
+ let desc : type a. a t -> string = function
+ | Label_declaration -> "label declaration"
+@@ -201,6 +220,7 @@
+ | Pstr_eval -> "toplevel expression"
+ | Pstr_extension -> "toplevel extension"
+ | Psig_extension -> "toplevel signature extension"
++ | Row_field -> "row field"
+
+ (*
+ let pattern : type a b c d. a t
+@@ -435,6 +455,7 @@
+ method! attribute (name, _) =
+ Location.raise_errorf ~loc:name.loc
+ "attribute not expected here, Ppx_core.Std.Attribute needs updating!"
++ name.txt
+
+ method private check_node : type a. a Context.t -> a -> a = fun context
node ->
+ let attrs = Context.get_attributes context node in
+@@ -480,6 +501,7 @@
+ method! module_expr x = super#module_expr
(self#check_node Context.Module_expr x)
+ method! value_binding x = super#value_binding
(self#check_node Context.Value_binding x)
+ method! module_binding x = super#module_binding
(self#check_node Context.Module_binding x)
++ method! row_field x = super#row_field
(self#check_node Context.Row_field x)
+
+ method! class_field x =
+ let x = self#check_node Context.Class_field x in
+diff -uNr ppx_core-113.33.00/src/attribute.mli
ppx_core-113.33.00+4.03/src/attribute.mli
+--- ppx_core-113.33.00/src/attribute.mli 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/attribute.mli 2016-03-23 17:20:19.000000000
+0100
+@@ -42,6 +42,7 @@
+ val pstr_eval : structure_item t
+ val pstr_extension : structure_item t
+ val psig_extension : signature_item t
++ val row_field : row_field t
+ end
+
+ (** [declare fully_qualified_name context payload_pattern k] declares an
attribute. [k] is
+diff -uNr ppx_core-113.33.00/src/common.ml
ppx_core-113.33.00+4.03/src/common.ml
+--- ppx_core-113.33.00/src/common.ml 2016-03-09 16:44:53.000000000 +0100
++++ ppx_core-113.33.00+4.03/src/common.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -16,7 +16,7 @@
+ List.fold_right
+ (fun (tp, _variance) acc ->
+ let loc = tp.ptyp_loc in
+- ptyp_arrow ~loc "" (f ~loc tp) acc)
++ ptyp_arrow ~loc Nolabel (f ~loc tp) acc)
+ td.ptype_params
+ result_type
+ ;;
+@@ -74,7 +74,9 @@
+
+ method! constructor_declaration cd =
+ (* Don't recurse through cd.pcd_res *)
+- List.iter (fun ty -> self#core_type ty) cd.pcd_args
++ match cd.pcd_args with
++ | Pcstr_tuple args -> List.iter (fun ty -> self#core_type ty) args
++ | Pcstr_record _ -> failwith "Pcstr_record not supported"
+ end
+
+ let types_are_recursive ?(stop_on_functions = true) ?(short_circuit = fun _
-> None)
+@@ -110,6 +112,7 @@
+ match payload with
+ | PStr [] -> name.loc
+ | PStr (x :: l) -> { x.pstr_loc with loc_end = (last x
l).pstr_loc.loc_end }
++ | PSig _ -> failwith "Not yet implemented"
+ | PTyp t -> t.ptyp_loc
+ | PPat (x, None) -> x.ppat_loc
+ | PPat (x, Some e) -> { x.ppat_loc with loc_end = e.pexp_loc.loc_end }
+diff -uNr ppx_core-113.33.00/src/gen/common.ml
ppx_core-113.33.00+4.03/src/gen/common.ml
+--- ppx_core-113.33.00/src/gen/common.ml 2016-03-09 16:44:53.000000000
+0100
++++ ppx_core-113.33.00+4.03/src/gen/common.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -70,8 +70,13 @@
+ | Type_variant cds ->
+ List.fold_left cds ~init:acc
+ ~f:(fun acc (cd : Types.constructor_declaration) ->
+- List.fold_left cd.cd_args ~init:acc
+- ~f:(add_type_expr_dependencies env))
++ match cd.cd_args with
++ | Cstr_tuple typ_exprs ->
++ List.fold_left typ_exprs ~init:acc ~f:(add_type_expr_dependencies
env)
++ | Cstr_record label_decls ->
++ List.fold_left label_decls ~init:acc
++ ~f:(fun acc (label_decl : Types.label_declaration) ->
++ add_type_expr_dependencies env acc label_decl.ld_type))
+ | Type_abstract ->
+ match td.type_manifest with
+ | None -> acc
+diff -uNr ppx_core-113.33.00/src/gen/gen_ast_builder.ml
ppx_core-113.33.00+4.03/src/gen/gen_ast_builder.ml
+--- ppx_core-113.33.00/src/gen/gen_ast_builder.ml 2016-03-09
16:44:53.000000000 +0100
++++ ppx_core-113.33.00+4.03/src/gen/gen_ast_builder.ml 2016-03-23
17:20:19.000000000 +0100
+@@ -121,57 +121,60 @@
+ open M
+
+ let gen_combinator_for_constructor ~wrapper:(wpath, wprefix, has_attrs)
path ~prefix cd =
+- let args =
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "x%d" i)
+- in
+- let exp =
+- Exp.construct (Loc.mk (fqn_longident path cd.cd_id))
+- (match args with
+- | [] -> None
+- | [x] -> Some (evar x)
+- | _ -> Some (Exp.tuple (List.map args ~f:evar)))
+- in
+- let body =
+- let fields =
+- [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc"))
+- , evar "loc"
+- )
+- ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc"))
+- , exp
+- )
+- ]
++ match cd.cd_args with
++ | Cstr_record _ -> failwith "Cstr_record not supported"
++ | Cstr_tuple cd_args ->
++ let args =
++ List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i)
++ in
++ let exp =
++ Exp.construct (Loc.mk (fqn_longident path cd.cd_id))
++ (match args with
++ | [] -> None
++ | [x] -> Some (evar x)
++ | _ -> Some (Exp.tuple (List.map args ~f:evar)))
+ in
+- let fields =
+- if has_attrs then
+- ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes"))
+- , [%expr []]
+- )
+- :: fields
++ let body =
++ let fields =
++ [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc"))
++ , evar "loc"
++ )
++ ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc"))
++ , exp
++ )
++ ]
++ in
++ let fields =
++ if has_attrs then
++ ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes"))
++ , [%expr []]
++ )
++ :: fields
++ else
++ fields
++ in
++ Exp.record fields None
++ in
++ let body =
++ (* match args with
++ | [] -> [%expr fun () -> [%e body]]
++ | _ ->*)
++ List.fold_right args ~init:body ~f:(fun arg acc ->
++ [%expr fun [%p pvar arg] -> [%e acc]])
++ in
++ (* let body =
++ if not has_attrs then
++ body
++ else
++ [%expr fun ?(attrs=[]) -> [%e body]]
++ in*)
++ let body =
++ if fixed_loc then
++ body
+ else
+- fields
++ [%expr fun ~loc -> [%e body]]
+ in
+- Exp.record fields None
+- in
+- let body =
+-(* match args with
+- | [] -> [%expr fun () -> [%e body]]
+- | _ ->*)
+- List.fold_right args ~init:body ~f:(fun arg acc ->
+- [%expr fun [%p pvar arg] -> [%e acc]])
+- in
+-(* let body =
+- if not has_attrs then
+- body
+- else
+- [%expr fun ?(attrs=[]) -> [%e body]]
+- in*)
+- let body =
+- if fixed_loc then
+- body
+- else
+- [%expr fun ~loc -> [%e body]]
+- in
+- [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]]
++ [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]]
+ ;;
+
+ let gen_combinator_for_record path ~prefix lds =
+@@ -189,10 +192,10 @@
+ let body =
+ let l = List.filter funcs ~f:(fun f -> f <> "loc" && f <> "attributes")
in
+ match l with
+- | [x] -> Exp.fun_ "" None (pvar x) body
++ | [x] -> Exp.fun_ Nolabel None (pvar x) body
+ | _ ->
+ List.fold_right l ~init:body ~f:(fun func acc ->
+- Exp.fun_ func None (pvar func) acc
++ Exp.fun_ (Labelled func) None (pvar func) acc
+ )
+ in
+ (* let body =
+diff -uNr ppx_core-113.33.00/src/gen/gen_ast_pattern.ml
ppx_core-113.33.00+4.03/src/gen/gen_ast_pattern.ml
+--- ppx_core-113.33.00/src/gen/gen_ast_pattern.ml 2016-03-09
16:44:53.000000000 +0100
++++ ppx_core-113.33.00+4.03/src/gen/gen_ast_pattern.ml 2016-03-23
17:20:19.000000000 +0100
+@@ -157,66 +157,69 @@
+ ]
+
+ let gen_combinator_for_constructor ?wrapper path ~prefix cd =
+- let args =
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "x%d" i)
+- in
+- let funcs =
+- List.mapi cd.cd_args ~f:(fun i _ -> sprintf "f%d" i)
+- in
+- let pat =
+- Pat.construct (Loc.mk (fqn_longident path cd.cd_id))
+- (match args with
+- | [] -> None
+- | [x] -> Some (pvar x)
+- | _ -> Some (Pat.tuple (List.map args ~f:pvar)))
+- in
+- let exp =
+- apply_parsers funcs (List.map args ~f:evar) cd.cd_args
+- in
+- let expected = without_prefix ~prefix (Ident.name cd.cd_id) in
+- let body =
+- [%expr
+- match x with
+- | [%p pat] -> ctx.matched <- ctx.matched + 1; [%e exp]
+- | _ -> fail loc [%e Exp.constant (Const_string (expected, None))]
+- ]
+- in
+- let body =
+- match wrapper with
+- | None -> body
+- | Some (path, prefix, has_attrs) ->
+- let body =
+- [%expr
+- let loc = [%e Exp.field (evar "x")
+- (Loc.mk @@ fqn_longident' path (prefix ^ "loc"))]
+- in
+- let x = [%e Exp.field (evar "x")
+- (Loc.mk @@ fqn_longident' path (prefix ^ "desc"))]
+- in
+- [%e body]
+- ]
+- in
+- if has_attrs then
+- [%expr
+- [%e assert_no_attributes ~path ~prefix];
+- [%e body]
+- ]
+- else
+- body
+- in
+- let body =
+- let loc =
++ match cd.cd_args with
++ | Cstr_record _ -> failwith "Cstr_record not supported"
++ | Cstr_tuple cd_args ->
++ let args =
++ List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i)
++ in
++ let funcs =
++ List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i)
++ in
++ let pat =
++ Pat.construct (Loc.mk (fqn_longident path cd.cd_id))
++ (match args with
++ | [] -> None
++ | [x] -> Some (pvar x)
++ | _ -> Some (Pat.tuple (List.map args ~f:pvar)))
++ in
++ let exp =
++ apply_parsers funcs (List.map args ~f:evar) cd_args
++ in
++ let expected = without_prefix ~prefix (Ident.name cd.cd_id) in
++ let body =
++ [%expr
++ match x with
++ | [%p pat] -> ctx.matched <- ctx.matched + 1; [%e exp]
++ | _ -> fail loc [%e Exp.constant (Pconst_string (expected, None))]
++ ]
++ in
++ let body =
+ match wrapper with
+- | None -> [%pat? loc]
+- | Some _ -> [%pat? _loc]
++ | None -> body
++ | Some (path, prefix, has_attrs) ->
++ let body =
++ [%expr
++ let loc = [%e Exp.field (evar "x")
++ (Loc.mk @@ fqn_longident' path (prefix ^ "loc"))]
++ in
++ let x = [%e Exp.field (evar "x")
++ (Loc.mk @@ fqn_longident' path (prefix ^ "desc"))]
++ in
++ [%e body]
++ ]
++ in
++ if has_attrs then
++ [%expr
++ [%e assert_no_attributes ~path ~prefix];
++ [%e body]
++ ]
++ else
++ body
+ in
+- [%expr T (fun ctx [%p loc] x k -> [%e body])]
+- in
+- let body =
+- List.fold_right funcs ~init:body ~f:(fun func acc ->
+- [%expr fun (T [%p pvar func]) -> [%e acc]])
+- in
+- [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]]
++ let body =
++ let loc =
++ match wrapper with
++ | None -> [%pat? loc]
++ | Some _ -> [%pat? _loc]
++ in
++ [%expr T (fun ctx [%p loc] x k -> [%e body])]
++ in
++ let body =
++ List.fold_right funcs ~init:body ~f:(fun func acc ->
++ [%expr fun (T [%p pvar func]) -> [%e acc]])
++ in
++ [%stri let [%p pvar (function_name_of_id ~prefix cd.cd_id)] = [%e body]]
+ ;;
+
+ let gen_combinator_for_record path ~prefix ~has_attrs lds =
+@@ -241,7 +244,7 @@
+ let body = [%expr T (fun ctx loc x k -> [%e body])] in
+ let body =
+ List.fold_right funcs ~init:body ~f:(fun func acc ->
+- Exp.fun_ func None [%pat? T [%p pvar func]] acc)
++ Exp.fun_ (Labelled func) None [%pat? T [%p pvar func]] acc)
+ in
+ [%stri let [%p pvar (Common.function_name_of_path path)] = [%e body]]
+ ;;
+diff -uNr ppx_core-113.33.00/src/gen/gen.ml
ppx_core-113.33.00+4.03/src/gen/gen.ml
+--- ppx_core-113.33.00/src/gen/gen.ml 2016-03-09 16:44:53.000000000 +0100
++++ ppx_core-113.33.00+4.03/src/gen/gen.ml 2016-03-23 17:20:19.000000000
+0100
+@@ -23,7 +23,7 @@
+
+ method apply
+ : Parsetree.expression
+- -> (string * Parsetree.expression) list
++ -> (Asttypes.arg_label * Parsetree.expression) list
+ -> Parsetree.expression
+
+ method abstract
+@@ -49,9 +49,9 @@
+ method class_params = []
+
+ method apply expr args = Exp.apply expr args
+- method abstract patt expr = Exp.fun_ "" None patt expr
++ method abstract patt expr = Exp.fun_ Nolabel None patt expr
+
+- method typ ty = Typ.arrow "" ty ty
++ method typ ty = Typ.arrow Nolabel ty ty
+
+ method array = [%expr Array.map]
+ method any = [%expr fun x -> x]
+@@ -68,7 +68,7 @@
+ method class_params = []
+
+ method apply expr args = Exp.apply expr args
+- method abstract patt expr = Exp.fun_ "" None patt expr
++ method abstract patt expr = Exp.fun_ Nolabel None patt expr
+
+ method typ ty = [%type: [%t ty] -> unit]
+ method array = [%expr Array.iter]
+@@ -88,8 +88,9 @@
+
+ method class_params = [(Typ.var "acc", Asttypes.Invariant)]
+
+- method apply expr args = Exp.apply expr (args @ [("", evar "acc")])
+- method abstract patt expr = Exp.fun_ "" None patt (Exp.fun_ "" None (pvar
"acc") expr)
++ method apply expr args = Exp.apply expr (args @ [(Asttypes.Nolabel, evar
"acc")])
++ method abstract patt expr =
++ Exp.fun_ Nolabel None patt (Exp.fun_ Nolabel None (pvar "acc") expr)
+
+ method typ ty = [%type: [%t ty] -> 'acc -> 'acc]
+ method array =
+@@ -121,8 +122,9 @@
+
+ method class_params = [(Typ.var "acc", Asttypes.Invariant)]
+
+- method apply expr args = Exp.apply expr (args @ [("", evar "acc")])
+- method abstract patt expr = Exp.fun_ "" None patt (Exp.fun_ "" None (pvar
"acc") expr)
++ method apply expr args = Exp.apply expr (args @ [(Asttypes.Nolabel, evar
"acc")])
++ method abstract patt expr =
++ Exp.fun_ Nolabel None patt (Exp.fun_ Nolabel None (pvar "acc") expr)
+
+ method typ ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc]
+ method array =
+@@ -180,12 +182,12 @@
+
+ method class_params = [(Typ.var "ctx", Asttypes.Invariant)]
+
+- method apply expr args = Exp.apply expr (("", evar "ctx") :: args)
++ method apply expr args = Exp.apply expr ((Asttypes.Nolabel, evar "ctx")
:: args)
+ method abstract patt expr =
+ if uses_ctx expr then
+- Exp.fun_ "" None (pvar "ctx") (Exp.fun_ "" None patt expr)
++ Exp.fun_ Nolabel None (pvar "ctx") (Exp.fun_ Nolabel None patt expr)
+ else
+- Exp.fun_ "" None (pvar "_ctx") (Exp.fun_ "" None patt expr)
++ Exp.fun_ Nolabel None (pvar "_ctx") (Exp.fun_ Nolabel None patt expr)
+
+ method typ ty = [%type: 'ctx -> [%t ty] -> [%t ty]]
+ method array = [%expr fun ctx a -> Array.map (f ctx) a]
+@@ -219,7 +221,7 @@
+ let ty = Typ.constr (Loc.mk ~loc (longident_of_path path)) params in
+ let ty =
+ List.fold_right
+- (fun param ty -> Typ.arrow "" (what#typ param) ty)
++ (fun param ty -> Typ.arrow Nolabel (what#typ param) ty)
+ params (what#typ ty)
+ in
+ Typ.poly vars ty
+@@ -244,7 +246,8 @@
+ | _ ->
+ Exp.apply map
+ (List.map
+- (fun te -> ("", type_expr_mapper ~what ~all_types ~var_mappers
te))
++ (fun te ->
++ (Asttypes.Nolabel, type_expr_mapper ~what ~all_types
~var_mappers te))
+ params)
+ else
+ what#any
+@@ -263,7 +266,8 @@
+ List.map2
+ (fun te var ->
+ (var,
+- what#apply (type_expr_mapper ~what ~all_types ~var_mappers te) [("",
evar var)]))
++ what#apply (type_expr_mapper ~what ~all_types ~var_mappers te)
++ [(Asttypes.Nolabel, evar var)]))
+ tes vars
+ ;;
+
+@@ -290,24 +294,27 @@
+ let cases =
+ List.map
+ (fun cd ->
+- let vars = vars_of_list cd.cd_args in
+- let cstr = Loc.mk ~loc (lident (Ident.name cd.cd_id)) in
+- let deconstruct =
+- Pat.construct cstr
+- (match vars with
+- | [] -> None
+- | _ -> Some (Pat.tuple (List.map pvar vars)))
+- in
+- let reconstruct =
+- Exp.construct cstr
+- (match vars with
+- | [] -> None
+- | _ -> Some (Exp.tuple (List.map evar vars)))
+- in
+- let mappers =
+- map_variables ~what ~all_types ~var_mappers vars cd.cd_args
+- in
+- Exp.case deconstruct (what#combine mappers ~reconstruct))
++ match cd.cd_args with
++ | Cstr_tuple args ->
++ let vars = vars_of_list args in
++ let cstr = Loc.mk ~loc (lident (Ident.name cd.cd_id)) in
++ let deconstruct =
++ Pat.construct cstr
++ (match vars with
++ | [] -> None
++ | _ -> Some (Pat.tuple (List.map pvar vars)))
++ in
++ let reconstruct =
++ Exp.construct cstr
++ (match vars with
++ | [] -> None
++ | _ -> Some (Exp.tuple (List.map evar vars)))
++ in
++ let mappers =
++ map_variables ~what ~all_types ~var_mappers vars args
++ in
++ Exp.case deconstruct (what#combine mappers ~reconstruct)
++ | Cstr_record _ -> failwith "Cstr_record not supported")
+ cds
+ in
+ what#abstract (pvar "x") (Exp.match_ (evar "x") cases)
+@@ -333,7 +340,7 @@
+ | Some te -> type_expr_mapper ~what ~all_types ~var_mappers te
+ in
+ List.fold_right
+- (fun (_, v) acc -> Exp.fun_ "" None (pvar v) acc)
++ (fun (_, v) acc -> Exp.fun_ Nolabel None (pvar v) acc)
+ var_mappers body
+ end
+ ;;
diff --git a/dev-ml/ppx_core/ppx_core-113.33.00.ebuild
b/dev-ml/ppx_core/ppx_core-113.33.00.ebuild
index d00d096..1ba1112 100644
--- a/dev-ml/ppx_core/ppx_core-113.33.00.ebuild
+++ b/dev-ml/ppx_core/ppx_core-113.33.00.ebuild
@@ -4,7 +4,7 @@
EAPI="5"
-inherit oasis
+inherit oasis eutils
DESCRIPTION="Standard library for ppx rewriters"
HOMEPAGE="http://www.janestreet.com/ocaml";
@@ -19,6 +19,10 @@ DEPEND="dev-ml/ppx_tools:="
RDEPEND="${DEPEND}"
DEPEND="${DEPEND} dev-ml/opam"
+src_prepare() {
+ has_version '>=dev-lang/ocaml-4.03' && epatch "${FILESDIR}/oc43.patch"
+}
+
src_configure() {
emake setup.exe
OASIS_SETUP_COMMAND="./setup.exe" oasis_src_configure
