diff -Nru ppxlib-0.24.0/ast/ast_helper_lite.ml ppxlib-0.27.0/ast/ast_helper_lite.ml --- ppxlib-0.24.0/ast/ast_helper_lite.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/ast_helper_lite.ml 2022-06-14 18:16:33.000000000 +0000 @@ -17,7 +17,7 @@ open Stdlib0 module Location = Astlib.Location module Longident = Astlib.Longident -open Astlib.Ast_412 +open Astlib.Ast_500 [@@@warning "-9"] @@ -25,15 +25,10 @@ open Parsetree type 'a with_loc = 'a Location.loc - type loc = Location.t - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list let default_loc = ref Location.none @@ -58,17 +53,11 @@ module Const = struct let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c let string ?quotation_delimiter ?(loc = !default_loc) s = @@ -90,29 +79,17 @@ } let attr d a = { d with ptyp_attributes = d.ptyp_attributes @ [ a ] } - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) let force_poly t = @@ -188,41 +165,26 @@ } let attr d a = { d with ppat_attributes = d.ppat_attributes @ [ a ] } - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let construct ?loc ?attrs a b = + mk ?loc ?attrs (Ppat_construct (a, Option.map (fun b -> ([], b)) b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) end @@ -236,82 +198,46 @@ } let attr d a = { d with pexp_attributes = d.pexp_attributes @ [ a ] } - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) let letop ?loc ?attrs let_ ands body = mk ?loc ?attrs (Pexp_letop { let_; ands; body }) let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - let case lhs ?guard rhs = { pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs } let binding_op op pat exp loc = @@ -323,19 +249,12 @@ { pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs } let attr d a = { d with pmty_attributes = d.pmty_attributes @ [ a ] } - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) end @@ -344,87 +263,50 @@ { pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs } let attr d a = { d with pmod_attributes = d.pmod_attributes @ [ a ] } - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) end module Sig = struct let mk ?(loc = !default_loc) d = { psig_desc = d; psig_loc = loc } - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) end module Str = struct let mk ?(loc = !default_loc) d = { pstr_desc = d; pstr_loc = loc } - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) end @@ -433,21 +315,13 @@ { pcl_desc = d; pcl_loc = loc; pcl_attributes = attrs } let attr d a = { d with pcl_attributes = d.pcl_attributes @ [ a ] } - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) end @@ -456,15 +330,10 @@ { pcty_desc = d; pcty_loc = loc; pcty_attributes = attrs } let attr d a = { d with pcty_attributes = d.pcty_attributes @ [ a ] } - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) end @@ -473,17 +342,11 @@ { pctf_desc = d; pctf_loc = loc; pctf_attributes = attrs } let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let attr d a = { d with pctf_attributes = d.pctf_attributes @ [ a ] } end @@ -492,23 +355,14 @@ { pcf_desc = d; pcf_loc = loc; pcf_attributes = attrs } let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - let attr d a = { d with pcf_attributes = d.pcf_attributes @ [ a ] } end @@ -600,10 +454,11 @@ ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) - ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(vars = []) + ?(args = Pcstr_tuple []) ?res name = { pcd_name = name; + pcd_vars = vars; pcd_args = args; pcd_res = res; pcd_loc = loc; @@ -648,11 +503,11 @@ pext_attributes = attrs; } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res - name = + let decl ?(loc = !default_loc) ?(attrs = []) ?(vars = []) + ?(args = Pcstr_tuple []) ?res name = { pext_name = name; - pext_kind = Pext_decl (args, res); + pext_kind = Pext_decl (vars, args, res); pext_loc = loc; pext_attributes = attrs; } @@ -691,6 +546,5 @@ { pof_desc = desc; pof_loc = loc; pof_attributes = attrs } let tag ?loc ?attrs label ty = mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = mk ?loc (Oinherit ty) end diff -Nru ppxlib-0.24.0/ast/ast_helper_lite.mli ppxlib-0.27.0/ast/ast_helper_lite.mli --- ppxlib-0.24.0/ast/ast_helper_lite.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/ast_helper_lite.mli 2022-06-14 18:16:33.000000000 +0000 @@ -13,22 +13,17 @@ (* *) (**************************************************************************) -(** Copy of Ast_helper from OCaml 4.12 with docstring related stuff removed *) +(** Copy of Ast_helper from OCaml 4.14 with docstring related stuff removed *) -open Astlib.Ast_412 +open Astlib.Ast_500 open Asttypes open Parsetree type 'a with_loc = 'a Astlib.Location.loc - type loc = Astlib.Location.t - type lid = Astlib.Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list (** {1 Default locations} *) @@ -44,19 +39,12 @@ module Const : sig val char : char -> constant - val string : ?quotation_delimiter:string -> ?loc:loc -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant end @@ -70,25 +58,20 @@ (** Type expressions *) module Typ : sig val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr : core_type -> attribute -> core_type - val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var : ?loc:loc -> ?attrs:attrs -> string -> core_type val arrow : ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val object_ : ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type val class_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type val variant : @@ -105,7 +88,6 @@ ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type - val force_poly : core_type -> core_type val varify_constructors : str list -> core_type -> core_type @@ -121,55 +103,35 @@ (** Patterns *) module Pat : sig val mk : ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr : pattern -> attribute -> pattern - val any : ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var : ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias : ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern val record : ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_ : ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack : ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension : ?loc:loc -> ?attrs:attrs -> extension -> pattern end (** Expressions *) module Exp : sig val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr : expression -> attribute -> expression - val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression val let_ : @@ -199,9 +161,7 @@ expression val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression val construct : @@ -260,9 +220,7 @@ ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_ : ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression val override : @@ -284,16 +242,13 @@ expression val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_ : ?loc:loc -> ?attrs:attrs -> expression -> expression val poly : ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression val object_ : ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression val open_ : @@ -308,11 +263,8 @@ expression val extension : ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable : ?loc:loc -> ?attrs:attrs -> unit -> expression - val case : pattern -> ?guard:expression -> expression -> case - val binding_op : str -> pattern -> expression -> loc -> binding_op end @@ -343,6 +295,7 @@ val constructor : ?loc:loc -> ?attrs:attrs -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> str -> @@ -381,6 +334,7 @@ val decl : ?loc:loc -> ?attrs:attrs -> + ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> str -> @@ -394,13 +348,9 @@ (** Module type expressions *) module Mty : sig val mk : ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr : module_type -> attribute -> module_type - val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias : ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature : ?loc:loc -> ?attrs:attrs -> signature -> module_type val functor_ : @@ -414,18 +364,14 @@ module_type val typeof_ : ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_type end (** Module expressions *) module Mod : sig val mk : ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr : module_expr -> attribute -> module_expr - val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure : ?loc:loc -> ?attrs:attrs -> structure -> module_expr val functor_ : @@ -438,77 +384,46 @@ ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr val unpack : ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_expr end (** Signature items *) module Sig : sig val mk : ?loc:loc -> signature_item_desc -> signature_item - val value : ?loc:loc -> value_description -> signature_item - val type_ : ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst : ?loc:loc -> type_declaration list -> signature_item - val type_extension : ?loc:loc -> type_extension -> signature_item - val exception_ : ?loc:loc -> type_exception -> signature_item - val module_ : ?loc:loc -> module_declaration -> signature_item - val mod_subst : ?loc:loc -> module_substitution -> signature_item - val rec_module : ?loc:loc -> module_declaration list -> signature_item - val modtype : ?loc:loc -> module_type_declaration -> signature_item - val open_ : ?loc:loc -> open_description -> signature_item - val include_ : ?loc:loc -> include_description -> signature_item - val class_ : ?loc:loc -> class_description list -> signature_item - val class_type : ?loc:loc -> class_type_declaration list -> signature_item - val extension : ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute : ?loc:loc -> attribute -> signature_item end (** Structure items *) module Str : sig val mk : ?loc:loc -> structure_item_desc -> structure_item - val eval : ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value : ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive : ?loc:loc -> value_description -> structure_item - val type_ : ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension : ?loc:loc -> type_extension -> structure_item - val exception_ : ?loc:loc -> type_exception -> structure_item - val module_ : ?loc:loc -> module_binding -> structure_item - val rec_module : ?loc:loc -> module_binding list -> structure_item - val modtype : ?loc:loc -> module_type_declaration -> structure_item - val open_ : ?loc:loc -> open_declaration -> structure_item - val class_ : ?loc:loc -> class_declaration list -> structure_item - val class_type : ?loc:loc -> class_type_declaration list -> structure_item - val include_ : ?loc:loc -> include_declaration -> structure_item - val extension : ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute : ?loc:loc -> attribute -> structure_item end @@ -559,11 +474,8 @@ (** Class type expressions *) module Cty : sig val mk : ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr : class_type -> attribute -> class_type - val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature : ?loc:loc -> ?attrs:attrs -> class_signature -> class_type val arrow : @@ -583,9 +495,7 @@ (** Class type fields *) module Ctf : sig val mk : ?loc:loc -> ?attrs:attrs -> class_type_field_desc -> class_type_field - val attr : class_type_field -> attribute -> class_type_field - val inherit_ : ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field val val_ : @@ -610,18 +520,14 @@ ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute : ?loc:loc -> attribute -> class_type_field end (** Class expressions *) module Cl : sig val mk : ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr : class_expr -> attribute -> class_expr - val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure : ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr val fun_ : @@ -660,7 +566,6 @@ (** Class fields *) module Cf : sig val mk : ?loc:loc -> ?attrs:attrs -> class_field_desc -> class_field - val attr : class_field -> attribute -> class_field val inherit_ : @@ -691,13 +596,9 @@ ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field val initializer_ : ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension : ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute : ?loc:loc -> attribute -> class_field - val virtual_ : core_type -> class_field_kind - val concrete : override_flag -> expression -> class_field_kind end diff -Nru ppxlib-0.24.0/ast/ast.ml ppxlib-0.27.0/ast/ast.ml --- ppxlib-0.24.0/ast/ast.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/ast.ml 2022-06-14 18:16:33.000000000 +0000 @@ -31,6 +31,7 @@ latter by the former. This is so that we can override iteration an the level of a longident loc - adding a type cases = case list + - replacing all occurences of "case list" by "cases" - replacing all the (*IF_CURRENT = Foo.bar*) by: = Foo.bar - removing the extra values at the end of the file - replacing app [type ...] by [and ...] to make everything one recursive block @@ -93,50 +94,39 @@ (* Order matters, used in polymorphic comparison *) and private_flag = Asttypes.private_flag = Private | Public - and mutable_flag = Asttypes.mutable_flag = Immutable | Mutable - and virtual_flag = Asttypes.virtual_flag = Virtual | Concrete - and override_flag = Asttypes.override_flag = Override | Fresh - and closed_flag = Asttypes.closed_flag = Closed | Open - and label = string and arg_label = Asttypes.arg_label = | Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string -(* ?label:T -> ... *) + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) and variance = Asttypes.variance = Covariant | Contravariant | NoVariance - and injectivity = Asttypes.injectivity = Injective | NoInjectivity (** Abstract syntax tree produced by parsing *) and constant = Parsetree.constant = | Pconst_integer of string * char option - (* 3 3l 3L 3n + (** Integer constants such as [3] [3l] [3L] [3n]. - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) + Suffixes [\[g-z\]\[G-Z\]] are accepted by the parser. Suffixes except + ['l'], ['L'] and ['n'] are rejected by the typechecker *) + | Pconst_char of char (** Character such as ['c']. *) | Pconst_string of string * location * string option - (* "constant" - {delim|other constant|delim} + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. - The location span the content of the string, without the delimiters. - *) + The location span the content of the string, without the delimiters. *) | Pconst_float of string * char option -(* 3.4 2e5 1.4e-4 + (** Float constant such as [3.4], [2e5] or [1.4e-4]. - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. -*) + Suffixes [g-z][G-Z] are accepted by the parser. Suffixes are rejected + by the typechecker. *) (** {1 Extension points} *) @@ -145,105 +135,119 @@ attr_payload : payload; attr_loc : location; } -(* [@id ARG] - [@@id ARG] +(** Attributes such as [\[@id ARG\]] and [\[@@id ARG\]]. - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. -*) + Metadata containers passed around within the AST. The compiler ignores + unknown attributes. *) and extension = string loc * payload -(* [%id ARG] - [%%id ARG] +(** Extension points such as [\[%id ARG\] and \[%%id ARG\]]. - Sub-language placeholder -- rejected by the typechecker. -*) + Sub-language placeholder -- rejected by the typechecker. *) and attributes = attribute list and payload = Parsetree.payload = | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) | PPat of pattern * expression option -(* ? P or ? P when E *) - -(* Type expressions *) + (** [? P] or [? P when E], in an attribute or an extension point *) (** {1 Core language} *) +(** {2 Type expressions} *) and core_type = Parsetree.core_type = { ptyp_desc : core_type_desc; ptyp_loc : location; ptyp_loc_stack : location_stack; - ptyp_attributes : attributes; (* ... [@id1] [@id2] *) + ptyp_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and core_type_desc = Parsetree.core_type_desc = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) + | Ptyp_any (** [_] *) + | Ptyp_var of string (** A type variable such as ['a] *) | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) + (** [Ptyp_arrow(lbl, T1, T2)] represents: + + - [T1 -> T2] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]}, + - [~l:T1 -> T2] when [lbl] is {{!Asttypes.arg_label.Labelled} + [Labelled]}, + - [?l:T1 -> T2] when [lbl] is {{!Asttypes.arg_label.Optional} + [Optional]}. *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn + (** [Ptyp_tuple(\[T1 ; ... ; Tn\])] represents a product type + [T1 * ... * Tn]. - Invariant: n >= 2 - *) + Invariant: [n >= 2]. *) | Ptyp_constr of longident_loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of longident_loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). + (** [Ptyp_constr(lident, l)] represents: - - As the core_type of a Pctf_method node. + - [tconstr] when [l=\[\]], + - [T tconstr] when [l=\[T\]], + - [(T1, ..., Tn) tconstr] when [l=\[T1 ; ... ; Tn\]]. *) + | Ptyp_object of object_field list * closed_flag + (** [Ptyp_object(\[ l1:T1; ...; ln:Tn \], flag)] represents: - - As the core_type of a Pexp_poly node. + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed} [Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open} [Open]}. *) + | Ptyp_class of longident_loc * core_type list + (** [Ptyp_class(tconstr, l)] represents: - - As the pld_type field of a label_declaration. + - [#tconstr] when [l=\[\]], + - [T #tconstr] when [l=\[T\]], + - [(T1, ..., Tn) #tconstr] when [l=\[T1 ; ... ; Tn\]]. *) + | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_variant of row_field list * closed_flag * label list option + (** [Ptyp_variant(\[`A;`B\], flag, labels)] represents: - - As a core_type of a Ptyp_object node. - *) - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension -(* [%id] *) + - [\[ `A|`B \]] when [flag] is {{!Asttypes.closed_flag.Closed} + [Closed]}, and [labels] is [None], + - [\[> `A|`B \]] when [flag] is {{!Asttypes.closed_flag.Open} [Open]}, + and [labels] is [None], + - [\[< `A|`B \]] when [flag] is {{!Asttypes.closed_flag.Closed} + [Closed]}, and [labels] is [Some \[\]], + - [\[< `A|`B > `X `Y \]] when [flag] is + {{!Asttypes.closed_flag.Closed} [Closed]}, and [labels] is + [Some \["X";"Y"\]]. *) + | Ptyp_poly of string loc list * core_type + (** ['a1 ... 'an. T] + + Can only appear in the following context: + + - As the {!core_type} of a {{!pattern_desc.Ppat_constraint} + [Ppat_constraint]} node corresponding to a constraint on a + let-binding: + + {[ let x : 'a1 ... 'an. T = e ... ]} + - Under {{!class_field_kind.Cfk_virtual} [Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a {{!class_type_field_desc.Pctf_method} + [Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly} [Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type} [pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object} [Ptyp_object]} + node. + + - As the {{!value_description.pval_type} [pval_type]} field of a + {!value_description}. *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_extension of extension (** [\[%id\]]. *) and package_type = longident_loc * (longident_loc * core_type) list -(* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) -*) +(** As {!package_type} typed values: + + - [(S, \[\])] represents [(module S)], + - [(S, \[(t1, T1) ; ... ; (tn, Tn)\])] represents + [(module S with type t1 = T1 and ... and tn = Tn)]. *) and row_field = Parsetree.row_field = { prf_desc : row_field_desc; @@ -253,20 +257,18 @@ and row_field_desc = Parsetree.row_field_desc = | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type -(* [ | t ] *) + (** [Rtag(`A, b, l)] represents: + + - [`A] when [b] is [true] and [l] is [\[\]], + - [`A of T] when [b] is [false] and [l] is [\[T\]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [\[T1;...Tn\]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [\[T1;...Tn\]]. + + - The [bool] field is true if the tag contains a constant (empty) + constructor. + - [&] occurs when several types are used for the same constructor (see + 4.2 in the manual) *) + | Rinherit of core_type (** [\[ | t \]] *) and object_field = Parsetree.object_field = { pof_desc : object_field_desc; @@ -278,205 +280,213 @@ | Otag of label loc * core_type | Oinherit of core_type -(* Patterns *) +(** {2 Patterns} *) + and pattern = Parsetree.pattern = { ppat_desc : pattern_desc; ppat_loc : location; ppat_loc_stack : location_stack; - ppat_attributes : attributes; (* ... [@id1] [@id2] *) + ppat_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and pattern_desc = Parsetree.pattern_desc = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) | Ppat_alias of pattern * string loc - (* P as 'a *) + (** An alias pattern such as [P as 'a] *) | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) | Ppat_interval of constant * constant - (* 'a'..'z' + (** Patterns such as ['a'..'z']. - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) + Other forms of interval are recognized by the parser but rejected by + the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) + (** Patterns [(P1, ..., Pn)]. - Invariant: n >= 2 - *) - | Ppat_construct of longident_loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) + Invariant: [n >= 2] *) + | Ppat_construct of longident_loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + + - [C] when [args] is [None], + - [C P] when [args] is [Some (\[\], P)] + - [C (P1, ..., Pn)] when [args] is + [Some (\[\], Ppat_tuple \[P1; ...; Pn\])] + - [C (type a b) P] when [args] is [Some (\[a; b\], P)] *) | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) + (** [Ppat_variant(`A, pat)] represents: + + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] *) | Ppat_record of (longident_loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) + (** [Ppat_record(\[(l1, P1) ; ... ; (ln, Pn)\], flag)] represents: - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of longident_loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) + - [{ l1=P1; ...; ln=Pn }] when [flag] is + {{!Asttypes.closed_flag.Closed} [Closed]} + - [{ l1=P1; ...; ln=Pn; _}] when [flag] is + {{!Asttypes.closed_flag.Open} [Open]} + + Invariant: [n > 0] *) + | Ppat_array of pattern list (** Pattern [\[| P1; ...; Pn |\]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of longident_loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) | Ppat_unpack of string option loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of longident_loc * pattern -(* M.(P) *) + (** [Ppat_unpack(s)] represents: + + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [\[%id\]] *) + | Ppat_open of longident_loc * pattern (** Pattern [M.(P)] *) + +(** {2 Value expressions} *) -(* Value expressions *) and expression = Parsetree.expression = { pexp_desc : expression_desc; pexp_loc : location; pexp_loc_stack : location_stack; - pexp_attributes : attributes; (* ... [@id1] [@id2] *) + pexp_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and expression_desc = Parsetree.expression_desc = - | Pexp_ident of longident_loc - (* x - M.x - *) + | Pexp_ident of longident_loc (** Identifiers such as [x] and [M.x] *) | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], [1L], + [1n] *) | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of cases - (* function P1 -> E1 | ... | Pn -> En *) + (** [Pexp_let(flag, \[(P1,E1) ; ... ; (Pn,En)\], E)] represents: + + - [let P1 = E1 and ... and Pn = EN in E] when [flag] is + {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is + {{!Asttypes.rec_flag.Recursive} [Recursive]}. *) + | Pexp_function of cases (** [function P1 -> E1 | ... | Pn -> En] *) | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) + (** [Pexp_fun(lbl, exp0, P, E1)] represents: + + - [fun P -> E1] when [lbl] is {{!Asttypes.arg_label.Nolabel} + [Nolabel]} and [exp0] is [None] + - [fun ~l:P -> E1] when [lbl] is {{!Asttypes.arg_label.Labelled} + [Labelled l]} and [exp0] is [None] + - [fun ?l:P -> E1] when [lbl] is {{!Asttypes.arg_label.Optional} + [Optional l]} and [exp0] is [None] + - [fun ?l:(P = E0) -> E1] when [lbl] is + {{!Asttypes.arg_label.Optional} [Optional l]} and [exp0] is + [Some E0] + + Notes: + + - If [E0] is provided, only {{!Asttypes.arg_label.Optional} + [Optional]} is allowed. + - [fun P1 P2 .. Pn -> E1] is represented as nested + {{!expression_desc.Pexp_fun} [Pexp_fun]}. + - [let f P = E] is represented using {{!expression_desc.Pexp_fun} + [Pexp_fun]}. *) | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (** [Pexp_apply(E0, \[(l1, E1) ; ... ; (ln, En)\])] represents + [E0 ~l1:E1 ... ~ln:En] - Invariant: n > 0 - *) + [li] can be {{!Asttypes.arg_label.Nolabel} [Nolabel]} (non labeled + argument), {{!Asttypes.arg_label.Labelled} [Labelled]} (labelled + arguments) or {{!Asttypes.arg_label.Optional} [Optional]} (optional + argument). + + Invariant: [n > 0] *) | Pexp_match of expression * cases - (* match E0 with P1 -> E1 | ... | Pn -> En *) + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_try of expression * cases - (* try E0 with P1 -> E1 | ... | Pn -> En *) + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_tuple of expression list - (* (E1, ..., En) + (** Expressions [(E1, ..., En)] - Invariant: n >= 2 - *) + Invariant: [n >= 2] *) | Pexp_construct of longident_loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) + (** [Pexp_construct(C, exp)] represents: + + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple\[E1;...;En\])] *) | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) + (** [Pexp_variant(`A, exp)] represents + + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] *) | Pexp_record of (longident_loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) + (** [Pexp_record(\[(l1,P1) ; ... ; (ln,Pn)\], exp0)] represents - Invariant: n > 0 - *) - | Pexp_field of expression * longident_loc - (* E.l *) + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + + Invariant: [n > 0] *) + | Pexp_field of expression * longident_loc (** [E.l] *) | Pexp_setfield of expression * longident_loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) + (** [E1.l <- E2] *) + | Pexp_array of expression list (** [\[| E1; ...; En |\]] *) | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) + (** [if E1 then E2 else E3] *) + | Pexp_sequence of expression * expression (** [E1; E2] *) + | Pexp_while of expression * expression (** [while E1 do E2 done] *) | Pexp_for of pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + + - [for i = E1 to E2 do E3 done] when [direction] is + {{!Asttypes.direction_flag.Upto} [Upto]} + - [for i = E1 downto E2 do E3 done] when [direction] is + {{!Asttypes.direction_flag.Downto} [Downto]} *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of longident_loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) + (** [Pexp_coerce(E, from, T)] represents + + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. *) + | Pexp_send of expression * label loc (** [E # m] *) + | Pexp_new of longident_loc (** [new M.c] *) + | Pexp_setinstvar of label loc * expression (** [x <- 2] *) | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) + (** [{< x1 = E1; ...; xn = En >}] *) | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) + (** [let module M = ME in E] *) | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) + (** [let exception C in E] *) | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) + (** [assert E]. + + Note: [assert false] is treated in a special way by the type-checker. *) + | Pexp_lazy of expression (** [lazy E] *) | Pexp_poly of expression * core_type option - (* Used for method bodies. + (** Used for method bodies. - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete} [Cfk_concrete]} for methods (not + values). *) + | Pexp_object of class_structure (** [object ... end] *) + | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) | Pexp_pack of module_expr - (* (module ME) + (** [(module ME)]. - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) + (** - [M.(E)] + - [let open M in E] + - [let open! M in E] *) | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable -(* . *) + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [\[%id\]] *) + | Pexp_unreachable (** [.] *) and case = Parsetree.case = { - (* (P -> E) or (P when E0 -> E) *) pc_lhs : pattern; pc_guard : expression option; pc_rhs : expression; } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) and letop = Parsetree.letop = { let_ : binding_op; @@ -491,52 +501,58 @@ pbop_loc : location; } -(* Value descriptions *) +(** {2 Value descriptions} *) + and value_description = Parsetree.value_description = { pval_name : string loc; pval_type : core_type; pval_prim : string list; - pval_attributes : attributes; - (* ... [@@id1] [@@id2] *) + pval_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) pval_loc : location; } +(** Values of type {!value_description} represents: -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) + - [val x: T], when {{!value_description.pval_prim} [pval_prim]} is [\[\]] + - [external x: T = "s1" ... "sn"] when {{!value_description.pval_prim} + [pval_prim]} is [\["s1";..."sn"\]] *) + +(** {2 Type declarations} *) -(* Type declarations *) and type_declaration = Parsetree.type_declaration = { ptype_name : string loc; ptype_params : (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) + (** [('a1,...'an) t] *) ptype_cstrs : (core_type * core_type * location) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) ptype_kind : type_kind; - ptype_private : private_flag; - (* = private ... *) - ptype_manifest : core_type option; - (* = T *) - ptype_attributes : attributes; - (* ... [@@id1] [@@id2] *) + ptype_private : private_flag; (** for [= private ...] *) + ptype_manifest : core_type option; (** represents [= T] *) + ptype_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) ptype_loc : location; } +(** Here are type declarations and their representation, for various + {{!type_declaration.ptype_kind} [ptype_kind]} and + {{!type_declaration.ptype_manifest} [ptype_manifest]} values: + + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract} + [Ptype_abstract]}, and [manifest] is [None], + - [type t = T0] when [type_kind] is {{!type_kind.Ptype_abstract} + [Ptype_abstract]}, and [manifest] is [Some T0], + - [type t = C of T | ...] when [type_kind] is {{!type_kind.Ptype_variant} + [Ptype_variant]}, and [manifest] is [None], + - [type t = T0 = C of T | ...] when [type_kind] is + {{!type_kind.Ptype_variant} [Ptype_variant]}, and [manifest] is [Some T0], + - [type t = {l: T; ...}] when [type_kind] is {{!type_kind.Ptype_record} + [Ptype_record]}, and [manifest] is [None], + - [type t = T0 = {l : T; ...}] when [type_kind] is + {{!type_kind.Ptype_record} [Ptype_record]}, and [manifest] is [Some T0], + - [type t = ..] when [type_kind] is {{!type_kind.Ptype_open} [Ptype_open]}, + and [manifest] is [None]. *) -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) and type_kind = Parsetree.type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (** Invariant: non-empty list *) | Ptype_open and label_declaration = Parsetree.label_declaration = { @@ -544,127 +560,154 @@ pld_mutable : mutable_flag; pld_type : core_type; pld_loc : location; - pld_attributes : attributes; (* l : T [@id1] [@id2] *) + pld_attributes : attributes; (** [l : T \[@id1\] \[@id2\]] *) } +(** - [{ ...; l: T; ... }] when {{!label_declaration.pld_mutable} [pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable} [Immutable]}, + - [{ ...; mutable l: T; ... }] when {{!label_declaration.pld_mutable} + [pld_mutable]} is {{!Asttypes.mutable_flag.Mutable} [Mutable]}. -(* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) + Note: [T] can be a {{!core_type_desc.Ptyp_poly} [Ptyp_poly]}. *) - Note: T can be a Ptyp_poly. -*) and constructor_declaration = Parsetree.constructor_declaration = { pcd_name : string loc; + pcd_vars : string loc list; pcd_args : constructor_arguments; pcd_res : core_type option; pcd_loc : location; - pcd_attributes : attributes; (* C of ... [@id1] [@id2] *) + pcd_attributes : attributes; (** [C of ... \[@id1\] \[@id2\]] *) } and constructor_arguments = Parsetree.constructor_arguments = | Pcstr_tuple of core_type list | Pcstr_record of label_declaration list + (** Values of type {!constructor_declaration} represents the constructor + arguments of: + + - [C of T1 * ... * Tn] when [res = None], and + [args = Pcstr_tuple \[T1; ... ; Tn\]], + - [C: T0] when [res = Some T0], and [args = Pcstr_tuple \[\]], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], and + [args = Pcstr_tuple \[T1; ... ; Tn\]], + - [C of {...}] when [res = None], and [args = Pcstr_record \[...\]], + - [C: {...} -> T0] when [res = Some T0], and + [args = Pcstr_record \[...\]]. *) -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) and type_extension = Parsetree.type_extension = { ptyext_path : longident_loc; ptyext_params : (core_type * (variance * injectivity)) list; ptyext_constructors : extension_constructor list; ptyext_private : private_flag; ptyext_loc : location; - ptyext_attributes : attributes; (* ... [@@id1] [@@id2] *) + ptyext_attributes : attributes; (** ... [@@id1] [@@id2] *) } -(* - type t += ... -*) +(** Definition of new extensions constructors for the extensive sum type [t] + ([type t += ...]). *) and extension_constructor = Parsetree.extension_constructor = { pext_name : string loc; pext_kind : extension_constructor_kind; pext_loc : location; - pext_attributes : attributes; (* C of ... [@id1] [@id2] *) + pext_attributes : attributes; (** [C of ... \[@id1\] \[@id2\]] *) } and type_exception = Parsetree.type_exception = { ptyexn_constructor : extension_constructor; ptyexn_loc : location; - ptyexn_attributes : attributes; + ptyexn_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) } +(** Definition of a new exception ([exception E]). *) and extension_constructor_kind = Parsetree.extension_constructor_kind = - | Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] describes a new extension + constructor. It can be: + + {ul + {- [C of T1 * ... * Tn] + when: + + - [existentials] is [\[\]], + - [c_args] is [\[T1; ...; Tn\]], + - [t_opt] is [None]. + } + {- [C: T0] + when + + - [existentials] is [\[\]], + - [c_args] is [\[\]], + - [t_opt] is [Some T0]. + } + {- [C: T1 * ... * Tn -> T0] + when + + - [existentials] is [\[\]], + - [c_args] is [\[T1; ...; Tn\]], + - [t_opt] is [Some T0]. + } + {- [C: 'a... . T1 * ... * Tn -> T0] + when + + - [existentials] is [\['a;...\]], + - [c_args] is [\[T1; ... ; Tn\]], + - [t_opt] is [Some T0]. + } + } *) | Pext_rebind of longident_loc -(* - | C = D - *) - -(* Type expressions for the class language *) + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) (** {1 Class language} *) +(** {2 Type expressions for the class language} *) and class_type = Parsetree.class_type = { pcty_desc : class_type_desc; pcty_loc : location; - pcty_attributes : attributes; (* ... [@id1] [@id2] *) + pcty_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and class_type_desc = Parsetree.class_type_desc = | Pcty_constr of longident_loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) + (** - [c] + - [\['a1, ..., 'an\] c] *) + | Pcty_signature of class_signature (** [object ... end] *) | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type -(* let open M in CT *) + (** [Pcty_arrow(lbl, T, CT)] represents: + + - [T -> CT] when [lbl] is {{!Asttypes.arg_label.Nolabel} [Nolabel]}, + - [~l:T -> CT] when [lbl] is {{!Asttypes.arg_label.Labelled} + [Labelled l]}, + - [?l:T -> CT] when [lbl] is {{!Asttypes.arg_label.Optional} + [Optional l]}. *) + | Pcty_extension of extension (** [%id] *) + | Pcty_open of open_description * class_type (** [let open M in CT] *) and class_signature = Parsetree.class_signature = { pcsig_self : core_type; pcsig_fields : class_type_field list; } -(* object('selfpat) ... end - object ... end (self = Ptyp_any) -*) +(** Values of type [class_signature] represents: + + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self} [pcsig_self]} is + {{!core_type_desc.Ptyp_any} [Ptyp_any]} *) and class_type_field = Parsetree.class_type_field = { pctf_desc : class_type_field_desc; pctf_loc : location; - pctf_attributes : attributes; (* ... [@@id1] [@@id2] *) + pctf_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) } and class_type_field_desc = Parsetree.class_type_field_desc = - | Pctf_inherit of class_type - (* inherit CT *) + | Pctf_inherit of class_type (** [inherit CT] *) | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) + (** [val x: T] *) | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T + (** [method x: T] - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension -(* [%%id] *) + Note: [T] can be a {{!core_type_desc.Ptyp_poly} [Ptyp_poly]}. *) + | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pctf_attribute of attribute (** [\[@@@id\]] *) + | Pctf_extension of extension (** [\[%%id\]] *) and 'a class_infos = 'a Parsetree.class_infos = { pci_virt : virtual_flag; @@ -672,131 +715,145 @@ pci_name : string loc; pci_expr : 'a; pci_loc : location; - pci_attributes : attributes; (* ... [@@id1] [@@id2] *) + pci_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) } -(* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... +(** Values of type [class_expr class_infos] represents: - Also used for "class type" declaration. -*) + - [class c = ...] + - [class \['a1,...,'an\] c = ...] + - [class virtual c = ...] -and class_description = class_type class_infos + They are also used for "class type" declaration. *) +and class_description = class_type class_infos and class_type_declaration = class_type class_infos -(* Value expressions for the class language *) +(** {2 Value expressions for the class language} *) + and class_expr = Parsetree.class_expr = { pcl_desc : class_expr_desc; pcl_loc : location; - pcl_attributes : attributes; (* ... [@id1] [@id2] *) + pcl_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and class_expr_desc = Parsetree.class_expr_desc = | Pcl_constr of longident_loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) + (** [c] and [\['a1, ..., 'an\] c] *) + | Pcl_structure of class_structure (** [object ... end] *) | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + + - [fun P -> CE] when [lbl] is {{!Asttypes.arg_label.Nolabel} + [Nolabel]} and [exp0] is [None], + - [fun ~l:P -> CE] when [lbl] is {{!Asttypes.arg_label.Labelled} + [Labelled l]} and [exp0] is [None], + - [fun ?l:P -> CE] when [lbl] is {{!Asttypes.arg_label.Optional} + [Optional l]} and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] when [lbl] is + {{!Asttypes.arg_label.Optional} [Optional l]} and [exp0] is + [Some E0]. *) | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (** [Pcl_apply(CE, \[(l1,E1) ; ... ; (ln,En)\])] represents + [CE ~l1:E1 ... ~ln:En]. [li] can be empty (non labeled argument) or + start with [?] (optional argument). - Invariant: n > 0 - *) + Invariant: [n > 0] *) | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr -(* let open M in CE *) + (** [Pcl_let(rec, \[(P1, E1); ... ; (Pn, En)\], CE)] represents: + + - [let P1 = E1 and ... and Pn = EN in CE] when [rec] is + {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] when [rec] is + {{!Asttypes.rec_flag.Recursive} [Recursive]}. *) + | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) + | Pcl_extension of extension (** [\[%id\]] *) + | Pcl_open of open_description * class_expr (** [let open M in CE] *) and class_structure = Parsetree.class_structure = { pcstr_self : pattern; pcstr_fields : class_field list; } -(* object(selfpat) ... end - object ... end (self = Ppat_any) -*) +(** Values of type {!class_structure} represents: + + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self} [pcstr_self]} is + {{!pattern_desc.Ppat_any} [Ppat_any]} *) and class_field = Parsetree.class_field = { pcf_desc : class_field_desc; pcf_loc : location; - pcf_attributes : attributes; (* ... [@@id1] [@@id2] *) + pcf_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) } and class_field_desc = Parsetree.class_field_desc = | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) + (** [Pcf_inherit(flag, CE, s)] represents: + + - [inherit CE] when [flag] is {{!Asttypes.override_flag.Fresh} + [Fresh]} and [s] is [None], + - [inherit CE as x] when [flag] is {{!Asttypes.override_flag.Fresh} + [Fresh]} and [s] is [Some x], + - [inherit! CE] when [flag] is {{!Asttypes.override_flag.Override} + [Override]} and [s] is [None], + - [inherit! CE as x] when [flag] is + {{!Asttypes.override_flag.Override} [Override]} and [s] is [Some x] *) | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) + (** [Pcf_val(x,flag, kind)] represents: + + - [val x = E] when [flag] is {{!Asttypes.mutable_flag.Immutable} + [Immutable]} and [kind] is {{!class_field_kind.Cfk_concrete} + [Cfk_concrete(Fresh, E)]} + - [val virtual x: T] when [flag] is + {{!Asttypes.mutable_flag.Immutable} [Immutable]} and [kind] is + {{!class_field_kind.Cfk_virtual} [Cfk_virtual(T)]} + - [val mutable x = E] when [flag] is {{!Asttypes.mutable_flag.Mutable} + [Mutable]} and [kind] is {{!class_field_kind.Cfk_concrete} + [Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] when [flag] is + {{!Asttypes.mutable_flag.Mutable} [Mutable]} and [kind] is + {{!class_field_kind.Cfk_virtual} [Cfk_virtual(T)]} *) | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension -(* [%%id] *) + (** - [method x = E] ([E] can be a {{!expression_desc.Pexp_poly} + [Pexp_poly]}) + - [method virtual x: T] ([T] can be a {{!core_type_desc.Ptyp_poly} + [Ptyp_poly]}) *) + | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pcf_initializer of expression (** [initializer E] *) + | Pcf_attribute of attribute (** [\[@@@id\]] *) + | Pcf_extension of extension (** [\[%%id\]] *) and class_field_kind = Parsetree.class_field_kind = | Cfk_virtual of core_type | Cfk_concrete of override_flag * expression and class_declaration = class_expr class_infos -(* Type expressions for the module language *) (** {1 Module language} *) +(** {2 Type expressions for the module language} *) and module_type = Parsetree.module_type = { pmty_desc : module_type_desc; pmty_loc : location; - pmty_attributes : attributes; (* ... [@id1] [@id2] *) + pmty_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and module_type_desc = Parsetree.module_type_desc = - | Pmty_ident of longident_loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) + | Pmty_ident of longident_loc (** [Pmty_ident(S)] represents [S] *) + | Pmty_signature of signature (** [sig ... end] *) | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of longident_loc -(* (module M) *) + (** [functor(X : MT1) -> MT2] *) + | Pmty_with of module_type * with_constraint list (** [MT with ...] *) + | Pmty_typeof of module_expr (** [module type of ME] *) + | Pmty_extension of extension (** [\[%id\]] *) + | Pmty_alias of longident_loc (** [(module M)] *) and functor_parameter = Parsetree.functor_parameter = - | Unit - (* () *) + | Unit (** [()] *) | Named of string option loc * module_type -(* (X : MT) Some X, MT - (_ : MT) None, MT *) + (** [Named(name, MT)] represents: + + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) and signature = signature_item list @@ -807,66 +864,57 @@ and signature_item_desc = Parsetree.signature_item_desc = | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) + (** - [val x: T] + - [external x: T = "s1" ... "sn"] *) | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) + (** [type t1 = ... and ... and tn = ...] *) | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) + (** [type t1 := ... and ... and tn := ...] *) + | Psig_typext of type_extension (** [type t1 += ...] *) + | Psig_exception of type_exception (** [exception C of T] *) + | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) + | Psig_modsubst of module_substitution (** [module X := M] *) | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) + (** [module rec X1 : MT1 and ... and Xn : MTn] *) | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) + (** [module type S = MT] and [module type S] *) + | Psig_modtypesubst of module_type_declaration (** [module type S := ...] *) + | Psig_open of open_description (** [open X] *) + | Psig_include of include_description (** [include MT] *) | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) + (** [class c1 : ... and ... and cn : ...] *) | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes -(* [%%id] *) + (** [class type ct1 = ... and ... and ctn = ...] *) + | Psig_attribute of attribute (** [\[@@@id\]] *) + | Psig_extension of extension * attributes (** [\[%%id\]] *) and module_declaration = Parsetree.module_declaration = { pmd_name : string option loc; pmd_type : module_type; - pmd_attributes : attributes; - (* ... [@@id1] [@@id2] *) + pmd_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) pmd_loc : location; } -(* S : MT *) +(** Values of type [module_declaration] represents [S : MT] *) and module_substitution = Parsetree.module_substitution = { pms_name : string loc; pms_manifest : longident_loc; - pms_attributes : attributes; + pms_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) pms_loc : location; } +(** Values of type [module_substitution] represents [S := M] *) and module_type_declaration = Parsetree.module_type_declaration = { pmtd_name : string loc; pmtd_type : module_type option; - pmtd_attributes : attributes; - (* ... [@@id1] [@@id2] *) + pmtd_attributes : attributes; (** [... \[@@id1\] \[@@id2\]] *) pmtd_loc : location; } -(* S = MT - S (abstract module type declaration, pmtd_type = None) -*) +(** Values of type [module_type_declaration] represents: + + - [S = MT], + - [S] for abstract module type declaration, when + {{!module_type_declaration.pmtd_type} [pmtd_type]} is [None]. *) and 'a open_infos = 'a Parsetree.open_infos = { popen_expr : 'a; @@ -874,14 +922,26 @@ popen_loc : location; popen_attributes : attributes; } +(** Values of type ['a open_infos] represents: + + - [open! X] when {{!open_infos.popen_override} [popen_override]} is + {{!Asttypes.override_flag.Override} [Override]} (silences the "used + identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override} [popen_override]} is + {{!Asttypes.override_flag.Fresh} [Fresh]} *) and open_description = longident_loc open_infos -(* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh -*) +(** Values of type [open_description] represents: + + - [open M.N] + - [open M(N).O] *) and open_declaration = module_expr open_infos +(** Values of type [open_declaration] represents: + + - [open M.N] + - [open M(N).O] + - [open struct ... end] *) and 'a include_infos = 'a Parsetree.include_infos = { pincl_mod : 'a; @@ -890,46 +950,44 @@ } and include_description = module_type include_infos -(* include MT *) +(** Values of type [include_description] represents [include MT] *) and include_declaration = module_expr include_infos -(* include ME *) +(** Values of type [include_declaration] represents [include ME] *) and with_constraint = Parsetree.with_constraint = | Pwith_type of longident_loc * type_declaration - (* with type X.t = ... + (** [with type X.t = ...] - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of longident_loc * longident_loc - (* with module X.Y = Z *) + Note: the last component of the longident must match the name of the + type_declaration. *) + | Pwith_module of longident_loc * longident_loc (** [with module X.Y = Z] *) + | Pwith_modtype of longident_loc * module_type + (** [with module type X.Y = Z] *) + | Pwith_modtypesubst of longident_loc * module_type + (** [with module type X.Y := sig end] *) | Pwith_typesubst of longident_loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) + (** [with type X.t := ..., same format as \[Pwith_type\]] *) | Pwith_modsubst of longident_loc * longident_loc -(* with module X.Y := Z *) + (** [with module X.Y := Z] *) + +(** {2 Value expressions for the module language} *) -(* Value expressions for the module language *) and module_expr = Parsetree.module_expr = { pmod_desc : module_expr_desc; pmod_loc : location; - pmod_attributes : attributes; (* ... [@id1] [@id2] *) + pmod_attributes : attributes; (** [... \[@id1\] \[@id2\]] *) } and module_expr_desc = Parsetree.module_expr_desc = - | Pmod_ident of longident_loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) + | Pmod_ident of longident_loc (** [X] *) + | Pmod_structure of structure (** [struct ... end] *) | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension -(* [%id] *) + (** [functor(X : MT1) -> ME] *) + | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) + | Pmod_unpack of expression (** [(val E)] *) + | Pmod_extension of extension (** [\[%id\]] *) and structure = structure_item list @@ -939,40 +997,35 @@ } and structure_item_desc = Parsetree.structure_item_desc = - | Pstr_eval of expression * attributes - (* E *) + | Pstr_eval of expression * attributes (** [E] *) | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) + (** [Pstr_value(rec, \[(P1, E1 ; ... ; (Pn, En))\])] represents: + + - [let P1 = E1 and ... and Pn = EN] when [rec] is + {{!Asttypes.rec_flag.Nonrecursive} [Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] when [rec] is + {{!Asttypes.rec_flag.Recursive} [Recursive]}. *) | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) + (** - [val x: T] + - [external x: T = "s1" ... "sn" ]*) | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) + (** [type t1 = ... and ... and tn = ...] *) + | Pstr_typext of type_extension (** [type t1 += ...] *) | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) + (** - [exception C of T] + - [exception C = M.X] *) + | Pstr_module of module_binding (** [module X = ME] *) | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) + (** [module rec X1 = ME1 and ... and Xn = MEn] *) + | Pstr_modtype of module_type_declaration (** [module type S = MT] *) + | Pstr_open of open_declaration (** [open X] *) | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) + (** [class c1 = ... and ... and cn = ...] *) | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes -(* [%%id] *) + (** [class type ct1 = ... and ... and ctn = ...] *) + | Pstr_include of include_declaration (** [include ME] *) + | Pstr_attribute of attribute (** [\[@@@id\]] *) + | Pstr_extension of extension * attributes (** [\[%%id\]] *) and value_binding = Parsetree.value_binding = { pvb_pat : pattern; @@ -987,16 +1040,14 @@ pmb_attributes : attributes; pmb_loc : location; } -(* X = ME *) - -(* Toplevel phrases *) +(** Values of type [module_binding] represents [module X = ME] *) (** {1 Toplevel} *) +(** {2 Toplevel phrases} *) and toplevel_phrase = Parsetree.toplevel_phrase = | Ptop_def of structure - | Ptop_dir of toplevel_directive -(* #use, #load ... *) + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) and toplevel_directive = Parsetree.toplevel_directive = { pdir_name : string loc; @@ -1020,15 +1071,10 @@ class virtual map = object (self) method virtual bool : bool -> bool - method virtual char : char -> char - method virtual int : int -> int - method virtual list : 'a. ('a -> 'a) -> 'a list -> 'a list - method virtual option : 'a. ('a -> 'a) -> 'a option -> 'a option - method virtual string : string -> string method position : position -> position = @@ -1074,19 +1120,12 @@ self#loc self#longident method rec_flag : rec_flag -> rec_flag = fun x -> x - method direction_flag : direction_flag -> direction_flag = fun x -> x - method private_flag : private_flag -> private_flag = fun x -> x - method mutable_flag : mutable_flag -> mutable_flag = fun x -> x - method virtual_flag : virtual_flag -> virtual_flag = fun x -> x - method override_flag : override_flag -> override_flag = fun x -> x - method closed_flag : closed_flag -> closed_flag = fun x -> x - method label : label -> label = self#string method arg_label : arg_label -> arg_label = @@ -1101,7 +1140,6 @@ Optional a method variance : variance -> variance = fun x -> x - method injectivity : injectivity -> injectivity = fun x -> x method constant : constant -> constant = @@ -1292,7 +1330,14 @@ Ppat_tuple a | Ppat_construct (a, b) -> let a = self#longident_loc a in - let b = self#option self#pattern b in + let b = + self#option + (fun (a, b) -> + let a = self#list (self#loc self#string) a in + let b = self#pattern b in + (a, b)) + b + in Ppat_construct (a, b) | Ppat_variant (a, b) -> let a = self#label a in @@ -1620,13 +1665,14 @@ method constructor_declaration : constructor_declaration -> constructor_declaration = - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> + fun { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in + let pcd_vars = self#list (self#loc self#string) pcd_vars in let pcd_args = self#constructor_arguments pcd_args in let pcd_res = self#option self#core_type pcd_res in let pcd_loc = self#location pcd_loc in let pcd_attributes = self#attributes pcd_attributes in - { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } + { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } method constructor_arguments : constructor_arguments -> constructor_arguments = @@ -1700,10 +1746,11 @@ : extension_constructor_kind -> extension_constructor_kind = fun x -> match x with - | Pext_decl (a, b) -> - let a = self#constructor_arguments a in - let b = self#option self#core_type b in - Pext_decl (a, b) + | Pext_decl (a, b, c) -> + let a = self#list (self#loc self#string) a in + let b = self#constructor_arguments b in + let c = self#option self#core_type c in + Pext_decl (a, b, c) | Pext_rebind a -> let a = self#longident_loc a in Pext_rebind a @@ -2034,6 +2081,9 @@ | Psig_modtype a -> let a = self#module_type_declaration a in Psig_modtype a + | Psig_modtypesubst a -> + let a = self#module_type_declaration a in + Psig_modtypesubst a | Psig_open a -> let a = self#open_description a in Psig_open a @@ -2118,6 +2168,14 @@ let a = self#longident_loc a in let b = self#longident_loc b in Pwith_module (a, b) + | Pwith_modtype (a, b) -> + let a = self#longident_loc a in + let b = self#module_type b in + Pwith_modtype (a, b) + | Pwith_modtypesubst (a, b) -> + let a = self#longident_loc a in + let b = self#module_type b in + Pwith_modtypesubst (a, b) | Pwith_typesubst (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in @@ -2286,15 +2344,10 @@ class virtual iter = object (self) method virtual bool : bool -> unit - method virtual char : char -> unit - method virtual int : int -> unit - method virtual list : 'a. ('a -> unit) -> 'a list -> unit - method virtual option : 'a. ('a -> unit) -> 'a option -> unit - method virtual string : string -> unit method position : position -> unit = @@ -2329,21 +2382,13 @@ self#longident b method longident_loc : longident_loc -> unit = self#loc self#longident - method rec_flag : rec_flag -> unit = fun _ -> () - method direction_flag : direction_flag -> unit = fun _ -> () - method private_flag : private_flag -> unit = fun _ -> () - method mutable_flag : mutable_flag -> unit = fun _ -> () - method virtual_flag : virtual_flag -> unit = fun _ -> () - method override_flag : override_flag -> unit = fun _ -> () - method closed_flag : closed_flag -> unit = fun _ -> () - method label : label -> unit = self#string method arg_label : arg_label -> unit = @@ -2354,7 +2399,6 @@ | Optional a -> self#string a method variance : variance -> unit = fun _ -> () - method injectivity : injectivity -> unit = fun _ -> () method constant : constant -> unit = @@ -2494,7 +2538,11 @@ | Ppat_tuple a -> self#list self#pattern a | Ppat_construct (a, b) -> self#longident_loc a; - self#option self#pattern b + self#option + (fun (a, b) -> + self#list (self#loc self#string) a; + self#pattern b) + b | Ppat_variant (a, b) -> self#label a; self#option self#pattern b @@ -2714,8 +2762,9 @@ self#attributes pld_attributes method constructor_declaration : constructor_declaration -> unit = - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> + fun { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> self#loc self#string pcd_name; + self#list (self#loc self#string) pcd_vars; self#constructor_arguments pcd_args; self#option self#core_type pcd_res; self#location pcd_loc; @@ -2766,9 +2815,10 @@ method extension_constructor_kind : extension_constructor_kind -> unit = fun x -> match x with - | Pext_decl (a, b) -> - self#constructor_arguments a; - self#option self#core_type b + | Pext_decl (a, b, c) -> + self#list (self#loc self#string) a; + self#constructor_arguments b; + self#option self#core_type c | Pext_rebind a -> self#longident_loc a method class_type : class_type -> unit = @@ -2990,6 +3040,7 @@ | Psig_modsubst a -> self#module_substitution a | Psig_recmodule a -> self#list self#module_declaration a | Psig_modtype a -> self#module_type_declaration a + | Psig_modtypesubst a -> self#module_type_declaration a | Psig_open a -> self#open_description a | Psig_include a -> self#include_description a | Psig_class a -> self#list self#class_description a @@ -3054,6 +3105,12 @@ | Pwith_module (a, b) -> self#longident_loc a; self#longident_loc b + | Pwith_modtype (a, b) -> + self#longident_loc a; + self#module_type b + | Pwith_modtypesubst (a, b) -> + self#longident_loc a; + self#module_type b | Pwith_typesubst (a, b) -> self#longident_loc a; self#type_declaration b @@ -3165,11 +3222,8 @@ class virtual ['acc] fold = object (self) method virtual bool : bool -> 'acc -> 'acc - method virtual char : char -> 'acc -> 'acc - method virtual int : int -> 'acc -> 'acc - method virtual list : 'a. ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc method virtual option @@ -3218,19 +3272,12 @@ self#loc self#longident method rec_flag : rec_flag -> 'acc -> 'acc = fun _ acc -> acc - method direction_flag : direction_flag -> 'acc -> 'acc = fun _ acc -> acc - method private_flag : private_flag -> 'acc -> 'acc = fun _ acc -> acc - method mutable_flag : mutable_flag -> 'acc -> 'acc = fun _ acc -> acc - method virtual_flag : virtual_flag -> 'acc -> 'acc = fun _ acc -> acc - method override_flag : override_flag -> 'acc -> 'acc = fun _ acc -> acc - method closed_flag : closed_flag -> 'acc -> 'acc = fun _ acc -> acc - method label : label -> 'acc -> 'acc = self#string method arg_label : arg_label -> 'acc -> 'acc = @@ -3241,7 +3288,6 @@ | Optional a -> self#string a acc method variance : variance -> 'acc -> 'acc = fun _ acc -> acc - method injectivity : injectivity -> 'acc -> 'acc = fun _ acc -> acc method constant : constant -> 'acc -> 'acc = @@ -3406,7 +3452,14 @@ | Ppat_tuple a -> self#list self#pattern a acc | Ppat_construct (a, b) -> let acc = self#longident_loc a acc in - let acc = self#option self#pattern b acc in + let acc = + self#option + (fun (a, b) acc -> + let acc = self#list (self#loc self#string) a acc in + let acc = self#pattern b acc in + acc) + b acc + in acc | Ppat_variant (a, b) -> let acc = self#label a acc in @@ -3681,8 +3734,9 @@ acc method constructor_declaration : constructor_declaration -> 'acc -> 'acc = - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> + fun { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> let acc = self#loc self#string pcd_name acc in + let acc = self#list (self#loc self#string) pcd_vars acc in let acc = self#constructor_arguments pcd_args acc in let acc = self#option self#core_type pcd_res acc in let acc = self#location pcd_loc acc in @@ -3746,9 +3800,10 @@ : extension_constructor_kind -> 'acc -> 'acc = fun x acc -> match x with - | Pext_decl (a, b) -> - let acc = self#constructor_arguments a acc in - let acc = self#option self#core_type b acc in + | Pext_decl (a, b, c) -> + let acc = self#list (self#loc self#string) a acc in + let acc = self#constructor_arguments b acc in + let acc = self#option self#core_type c acc in acc | Pext_rebind a -> self#longident_loc a acc @@ -4012,6 +4067,7 @@ | Psig_modsubst a -> self#module_substitution a acc | Psig_recmodule a -> self#list self#module_declaration a acc | Psig_modtype a -> self#module_type_declaration a acc + | Psig_modtypesubst a -> self#module_type_declaration a acc | Psig_open a -> self#open_description a acc | Psig_include a -> self#include_description a acc | Psig_class a -> self#list self#class_description a acc @@ -4086,6 +4142,14 @@ let acc = self#longident_loc a acc in let acc = self#longident_loc b acc in acc + | Pwith_modtype (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#module_type b acc in + acc + | Pwith_modtypesubst (a, b) -> + let acc = self#longident_loc a acc in + let acc = self#module_type b acc in + acc | Pwith_typesubst (a, b) -> let acc = self#longident_loc a acc in let acc = self#type_declaration b acc in @@ -4213,9 +4277,7 @@ class virtual ['acc] fold_map = object (self) method virtual bool : bool -> 'acc -> bool * 'acc - method virtual char : char -> 'acc -> char * 'acc - method virtual int : int -> 'acc -> int * 'acc method virtual list @@ -4497,7 +4559,14 @@ (Ppat_tuple a, acc) | Ppat_construct (a, b) -> let a, acc = self#longident_loc a acc in - let b, acc = self#option self#pattern b acc in + let b, acc = + self#option + (fun (a, b) acc -> + let a, acc = self#list (self#loc self#string) a acc in + let b, acc = self#pattern b acc in + ((a, b), acc)) + b acc + in (Ppat_construct (a, b), acc) | Ppat_variant (a, b) -> let a, acc = self#label a acc in @@ -4831,13 +4900,14 @@ method constructor_declaration : constructor_declaration -> 'acc -> constructor_declaration * 'acc = - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> + fun { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } acc -> let pcd_name, acc = self#loc self#string pcd_name acc in + let pcd_vars, acc = self#list (self#loc self#string) pcd_vars acc in let pcd_args, acc = self#constructor_arguments pcd_args acc in let pcd_res, acc = self#option self#core_type pcd_res acc in let pcd_loc, acc = self#location pcd_loc acc in let pcd_attributes, acc = self#attributes pcd_attributes acc in - ({ pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes }, acc) + ({ pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes }, acc) method constructor_arguments : constructor_arguments -> 'acc -> constructor_arguments * 'acc = @@ -4914,10 +4984,11 @@ extension_constructor_kind * 'acc = fun x acc -> match x with - | Pext_decl (a, b) -> - let a, acc = self#constructor_arguments a acc in - let b, acc = self#option self#core_type b acc in - (Pext_decl (a, b), acc) + | Pext_decl (a, b, c) -> + let a, acc = self#list (self#loc self#string) a acc in + let b, acc = self#constructor_arguments b acc in + let c, acc = self#option self#core_type c acc in + (Pext_decl (a, b, c), acc) | Pext_rebind a -> let a, acc = self#longident_loc a acc in (Pext_rebind a, acc) @@ -5266,6 +5337,9 @@ | Psig_modtype a -> let a, acc = self#module_type_declaration a acc in (Psig_modtype a, acc) + | Psig_modtypesubst a -> + let a, acc = self#module_type_declaration a acc in + (Psig_modtypesubst a, acc) | Psig_open a -> let a, acc = self#open_description a acc in (Psig_open a, acc) @@ -5365,6 +5439,14 @@ let a, acc = self#longident_loc a acc in let b, acc = self#longident_loc b acc in (Pwith_module (a, b), acc) + | Pwith_modtype (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#module_type b acc in + (Pwith_modtype (a, b), acc) + | Pwith_modtypesubst (a, b) -> + let a, acc = self#longident_loc a acc in + let b, acc = self#module_type b acc in + (Pwith_modtypesubst (a, b), acc) | Pwith_typesubst (a, b) -> let a, acc = self#longident_loc a acc in let b, acc = self#type_declaration b acc in @@ -5538,11 +5620,8 @@ class virtual ['ctx] map_with_context = object (self) method virtual bool : 'ctx -> bool -> bool - method virtual char : 'ctx -> char -> char - method virtual int : 'ctx -> int -> int - method virtual list : 'a. ('ctx -> 'a -> 'a) -> 'ctx -> 'a list -> 'a list method virtual option @@ -5598,16 +5677,13 @@ fun _ctx x -> x method private_flag : 'ctx -> private_flag -> private_flag = fun _ctx x -> x - method mutable_flag : 'ctx -> mutable_flag -> mutable_flag = fun _ctx x -> x - method virtual_flag : 'ctx -> virtual_flag -> virtual_flag = fun _ctx x -> x method override_flag : 'ctx -> override_flag -> override_flag = fun _ctx x -> x method closed_flag : 'ctx -> closed_flag -> closed_flag = fun _ctx x -> x - method label : 'ctx -> label -> label = self#string method arg_label : 'ctx -> arg_label -> arg_label = @@ -5622,7 +5698,6 @@ Optional a method variance : 'ctx -> variance -> variance = fun _ctx x -> x - method injectivity : 'ctx -> injectivity -> injectivity = fun _ctx x -> x method constant : 'ctx -> constant -> constant = @@ -5814,7 +5889,14 @@ Ppat_tuple a | Ppat_construct (a, b) -> let a = self#longident_loc ctx a in - let b = self#option self#pattern ctx b in + let b = + self#option + (fun ctx (a, b) -> + let a = self#list (self#loc self#string) ctx a in + let b = self#pattern ctx b in + (a, b)) + ctx b + in Ppat_construct (a, b) | Ppat_variant (a, b) -> let a = self#label ctx a in @@ -6143,13 +6225,14 @@ method constructor_declaration : 'ctx -> constructor_declaration -> constructor_declaration = - fun ctx { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> + fun ctx { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string ctx pcd_name in + let pcd_vars = self#list (self#loc self#string) ctx pcd_vars in let pcd_args = self#constructor_arguments ctx pcd_args in let pcd_res = self#option self#core_type ctx pcd_res in let pcd_loc = self#location ctx pcd_loc in let pcd_attributes = self#attributes ctx pcd_attributes in - { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } + { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } method constructor_arguments : 'ctx -> constructor_arguments -> constructor_arguments = @@ -6224,10 +6307,11 @@ : 'ctx -> extension_constructor_kind -> extension_constructor_kind = fun ctx x -> match x with - | Pext_decl (a, b) -> - let a = self#constructor_arguments ctx a in - let b = self#option self#core_type ctx b in - Pext_decl (a, b) + | Pext_decl (a, b, c) -> + let a = self#list (self#loc self#string) ctx a in + let b = self#constructor_arguments ctx b in + let c = self#option self#core_type ctx c in + Pext_decl (a, b, c) | Pext_rebind a -> let a = self#longident_loc ctx a in Pext_rebind a @@ -6561,6 +6645,9 @@ | Psig_modtype a -> let a = self#module_type_declaration ctx a in Psig_modtype a + | Psig_modtypesubst a -> + let a = self#module_type_declaration ctx a in + Psig_modtypesubst a | Psig_open a -> let a = self#open_description ctx a in Psig_open a @@ -6651,6 +6738,14 @@ let a = self#longident_loc ctx a in let b = self#longident_loc ctx b in Pwith_module (a, b) + | Pwith_modtype (a, b) -> + let a = self#longident_loc ctx a in + let b = self#module_type ctx b in + Pwith_modtype (a, b) + | Pwith_modtypesubst (a, b) -> + let a = self#longident_loc ctx a in + let b = self#module_type ctx b in + Pwith_modtypesubst (a, b) | Pwith_typesubst (a, b) -> let a = self#longident_loc ctx a in let b = self#type_declaration ctx b in @@ -6823,21 +6918,13 @@ class virtual ['res] lift = object (self) method virtual record : (string * 'res) list -> 'res - method virtual constr : string -> 'res list -> 'res - method virtual tuple : 'res list -> 'res - method virtual bool : bool -> 'res - method virtual char : char -> 'res - method virtual int : int -> 'res - method virtual list : 'a. ('a -> 'res) -> 'a list -> 'res - method virtual option : 'a. ('a -> 'res) -> 'a option -> 'res - method virtual string : string -> 'res method position : position -> 'res = @@ -7174,7 +7261,14 @@ self#constr "Ppat_tuple" [ a ] | Ppat_construct (a, b) -> let a = self#longident_loc a in - let b = self#option self#pattern b in + let b = + self#option + (fun (a, b) -> + let a = self#list (self#loc self#string) a in + let b = self#pattern b in + self#tuple [ a; b ]) + b + in self#constr "Ppat_construct" [ a; b ] | Ppat_variant (a, b) -> let a = self#label a in @@ -7529,8 +7623,9 @@ ] method constructor_declaration : constructor_declaration -> 'res = - fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> + fun { pcd_name; pcd_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in + let pcd_vars = self#list (self#loc self#string) pcd_vars in let pcd_args = self#constructor_arguments pcd_args in let pcd_res = self#option self#core_type pcd_res in let pcd_loc = self#location pcd_loc in @@ -7538,6 +7633,7 @@ self#record [ ("pcd_name", pcd_name); + ("pcd_vars", pcd_vars); ("pcd_args", pcd_args); ("pcd_res", pcd_res); ("pcd_loc", pcd_loc); @@ -7625,10 +7721,11 @@ method extension_constructor_kind : extension_constructor_kind -> 'res = fun x -> match x with - | Pext_decl (a, b) -> - let a = self#constructor_arguments a in - let b = self#option self#core_type b in - self#constr "Pext_decl" [ a; b ] + | Pext_decl (a, b, c) -> + let a = self#list (self#loc self#string) a in + let b = self#constructor_arguments b in + let c = self#option self#core_type c in + self#constr "Pext_decl" [ a; b; c ] | Pext_rebind a -> let a = self#longident_loc a in self#constr "Pext_rebind" [ a ] @@ -7992,6 +8089,9 @@ | Psig_modtype a -> let a = self#module_type_declaration a in self#constr "Psig_modtype" [ a ] + | Psig_modtypesubst a -> + let a = self#module_type_declaration a in + self#constr "Psig_modtypesubst" [ a ] | Psig_open a -> let a = self#open_description a in self#constr "Psig_open" [ a ] @@ -8103,6 +8203,14 @@ let a = self#longident_loc a in let b = self#longident_loc b in self#constr "Pwith_module" [ a; b ] + | Pwith_modtype (a, b) -> + let a = self#longident_loc a in + let b = self#module_type b in + self#constr "Pwith_modtype" [ a; b ] + | Pwith_modtypesubst (a, b) -> + let a = self#longident_loc a in + let b = self#module_type b in + self#constr "Pwith_modtypesubst" [ a; b ] | Pwith_typesubst (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in @@ -8290,3 +8398,4 @@ end [@@@end] +[@@@end] diff -Nru ppxlib-0.24.0/ast/import.ml ppxlib-0.27.0/ast/import.ml --- ppxlib-0.24.0/ast/import.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/import.ml 2022-06-14 18:16:33.000000000 +0000 @@ -4,7 +4,7 @@ It must be opened in all modules, especially the ones coming from the compiler. *) -module Js = Versions.OCaml_412 +module Js = Versions.OCaml_500 module Ocaml = Versions.OCaml_current module Select_ast (Ocaml : Versions.OCaml_version) = struct @@ -81,7 +81,6 @@ fun (x, y) -> (f x, g y) let of_ocaml_mapper item f ctxt x = to_ocaml item x |> f ctxt |> of_ocaml item - let to_ocaml_mapper item f ctxt x = of_ocaml item x |> f ctxt |> to_ocaml item end @@ -101,7 +100,6 @@ module Of_ocaml = Versions.Convert (Ocaml) (Js) let implementation lexbuf = implementation lexbuf |> Of_ocaml.copy_structure - let interface lexbuf = interface lexbuf |> Of_ocaml.copy_signature let toplevel_phrase lexbuf = @@ -111,8 +109,6 @@ use_file lexbuf |> List.map Of_ocaml.copy_toplevel_phrase let core_type lexbuf = core_type lexbuf |> Of_ocaml.copy_core_type - let expression lexbuf = expression lexbuf |> Of_ocaml.copy_expression - let pattern lexbuf = pattern lexbuf |> Of_ocaml.copy_pattern end diff -Nru ppxlib-0.24.0/ast/location_error.ml ppxlib-0.27.0/ast/location_error.ml --- ppxlib-0.24.0/ast/location_error.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/location_error.ml 2022-06-14 18:16:33.000000000 +0000 @@ -39,5 +39,4 @@ loc let of_exn = Astlib.Location.Error.of_exn - let raise error = raise (Astlib.Location.Error error) diff -Nru ppxlib-0.24.0/ast/location_error.mli ppxlib-0.27.0/ast/location_error.mli --- ppxlib-0.24.0/ast/location_error.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/location_error.mli 2022-06-14 18:16:33.000000000 +0000 @@ -3,19 +3,11 @@ type t = Astlib.Location.Error.t val of_exn : exn -> t option - val register_error_of_exn : (exn -> t option) -> unit - val message : t -> string - val set_message : t -> string -> t - val make : loc:Location.t -> string -> sub:(Location.t * string) list -> t - val to_extension : t -> Import.Parsetree.extension - val raise : t -> 'a - val update_loc : t -> Location.t -> t - val get_location : t -> Location.t diff -Nru ppxlib-0.24.0/ast/supported_version/supported_version.ml ppxlib-0.27.0/ast/supported_version/supported_version.ml --- ppxlib-0.24.0/ast/supported_version/supported_version.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/supported_version/supported_version.ml 2022-06-14 18:16:33.000000000 +0000 @@ -15,9 +15,11 @@ (4, 12); (4, 13); (4, 14); + (5, 0); ] -let to_string (a, b) = Printf.sprintf "%d.%02d" a b +let to_string (a, b) = + if a < 5 then Printf.sprintf "%d.%02d" a b else Printf.sprintf "%d.%d" a b let to_int (a, b) = (a * 100) + b diff -Nru ppxlib-0.24.0/ast/versions.ml ppxlib-0.27.0/ast/versions.ml --- ppxlib-0.24.0/ast/versions.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/versions.ml 2022-06-14 18:16:33.000000000 +0000 @@ -499,6 +499,13 @@ let string_version = "4.14" end let ocaml_414 : OCaml_414.types ocaml_version = (module OCaml_414) +module OCaml_500 = struct + module Ast = Astlib.Ast_500 + include Make_witness(Astlib.Ast_500) + let version = 500 + let string_version = "5.0" +end +let ocaml_500 : OCaml_500.types ocaml_version = (module OCaml_500) (*$*) let all_versions : (module OCaml_version) list = [ @@ -517,6 +524,7 @@ (module OCaml_412 : OCaml_version); (module OCaml_413 : OCaml_version); (module OCaml_414 : OCaml_version); +(module OCaml_500 : OCaml_version); (*$*) ] @@ -549,6 +557,8 @@ (Astlib.Migrate_412_413)(Astlib.Migrate_413_412) include Register_migration(OCaml_413)(OCaml_414) (Astlib.Migrate_413_414)(Astlib.Migrate_414_413) +include Register_migration(OCaml_414)(OCaml_500) + (Astlib.Migrate_414_500)(Astlib.Migrate_500_414) (*$*) module OCaml_current = OCaml_OCAML_VERSION diff -Nru ppxlib-0.24.0/ast/versions.mli ppxlib-0.27.0/ast/versions.mli --- ppxlib-0.24.0/ast/versions.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/versions.mli 2022-06-14 18:16:33.000000000 +0000 @@ -128,6 +128,7 @@ module OCaml_412 : OCaml_version with module Ast = Astlib.Ast_412 module OCaml_413 : OCaml_version with module Ast = Astlib.Ast_413 module OCaml_414 : OCaml_version with module Ast = Astlib.Ast_414 +module OCaml_500 : OCaml_version with module Ast = Astlib.Ast_500 (*$*) (* An alias to the current compiler version *) diff -Nru ppxlib-0.24.0/ast/warn.ml ppxlib-0.27.0/ast/warn.ml --- ppxlib-0.24.0/ast/warn.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ast/warn.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1,9 +1,6 @@ open! Import let default_print_warning _loc = () - let about_ite_branch_ref = ref default_print_warning - let care_about_ite_branch = ref false - let about_ite_branch loc = !about_ite_branch_ref loc diff -Nru ppxlib-0.24.0/astlib/ast_414.ml ppxlib-0.27.0/astlib/ast_414.ml --- ppxlib-0.24.0/astlib/ast_414.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/ast_414.ml 2022-06-14 18:16:33.000000000 +0000 @@ -46,8 +46,8 @@ type arg_label (*IF_CURRENT = Asttypes.arg_label *) = Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) type 'a loc = 'a Location.loc = { txt : 'a; @@ -68,25 +68,24 @@ open Asttypes type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n + | Pconst_integer of string * char option + (** Integer constants such as [3] [3l] [3L] [3n]. - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker + Suffixes [[g-z][G-Z]] are accepted by the parser. + Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker *) - | Pconst_char of char - (* 'c' *) + | Pconst_char of char (** Character such as ['c']. *) | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. - The location span the content of the string, without the delimiters. + The location span the content of the string, without the delimiters. *) | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 + (** Float constant such as [3.4], [2e5] or [1.4e-4]. - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. *) type location_stack = Location.t list @@ -98,16 +97,14 @@ attr_payload : payload; attr_loc : Location.t; } - (* [@id ARG] - [@@id ARG] + (** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. Metadata containers passed around within the AST. The compiler ignores unknown attributes. *) and extension = string loc * payload - (* [%id ARG] - [%%id ARG] + (** Extension points such as [[%id ARG] and [%%id ARG]]. Sub-language placeholder -- rejected by the typechecker. *) @@ -116,91 +113,112 @@ and payload (*IF_CURRENT = Parsetree.payload *) = | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) (** {1 Core language} *) - - (* Type expressions *) + (** {2 Type expressions} *) and core_type (*IF_CURRENT = Parsetree.core_type *) = { ptyp_desc: core_type_desc; ptyp_loc: Location.t; ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) + | Ptyp_any (** [_] *) + | Ptyp_var of string (** A type variable such as ['a] *) | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. - Invariant: n >= 2 - *) + Invariant: [n >= 2]. + *) | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. + *) | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. + *) | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_alias of core_type * string (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) + (** [Ptyp_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some ["X";"Y"]]. + *) | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T + (** ['a1 ... 'an. T] - Can only appear in the following context: + Can only appear in the following context: - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... + - As the {!core_type} of a + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: - - Under Cfk_virtual for methods (not values). + {[let x : 'a1 ... 'an. T = e ...]} + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). - - As the core_type of a Pctf_method node. + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. - - As the core_type of a Pexp_poly node. + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. - - As the pld_type field of a label_declaration. + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. - - As a core_type of a Ptyp_object node. + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. - - As the pval_type field of a value_description. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_extension of extension (** [[%id]]. *) and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) + (** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(module S with type t1 = T1 and ... and tn = Tn)]. + *) and row_field (*IF_CURRENT = Parsetree.row_field *) = { prf_desc : row_field_desc; @@ -210,18 +228,18 @@ and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ | t ] *) + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. + + - The [bool] field is true if the tag contains a + constant (empty) constructor. + - [&] occurs when several types are used for the same constructor + (see 4.2 in the manual) + *) + | Rinherit of core_type (** [[ | t ]] *) and object_field (*IF_CURRENT = Parsetree.object_field *) = { pof_desc : object_field_desc; @@ -233,213 +251,224 @@ | Otag of label loc * core_type | Oinherit of core_type - (* Patterns *) + (** {2 Patterns} *) and pattern (*IF_CURRENT = Parsetree.pattern *) = { ppat_desc: pattern_desc; ppat_loc: Location.t; ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) + ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) | Ppat_alias of pattern * string loc - (* P as 'a *) + (** An alias pattern such as [P as 'a] *) | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) | Ppat_interval of constant * constant - (* 'a'..'z' + (** Patterns such as ['a'..'z']. - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) + (** Patterns [(P1, ..., Pn)]. - Invariant: n >= 2 - *) + Invariant: [n >= 2] + *) | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (* C None - C P Some ([], P) - C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) - C (type a b) P Some ([a; b], P) - *) + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] + *) | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] + *) | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) - (* Value expressions *) + (** {2 Value expressions} *) and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } + { + pexp_desc: expression_desc; + pexp_loc: Location.t; + pexp_loc_stack: location_stack; + pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = | Pexp_ident of Longident.t loc - (* x - M.x - *) + (** Identifiers such as [x] and [M.x] + *) | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], + [1L], [1n] *) | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) + (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) + (** [Pexp_fun(lbl, exp0, P, E1)] represents: + - [fun P -> E1] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [fun ~l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [fun ?l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [fun ?l:(P = E0) -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Notes: + - If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + - [fun P1 P2 .. Pn -> E1] is represented as nested + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + - [let f P = E] is represented using + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + *) | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] - Invariant: n > 0 - *) + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). + + Invariant: [n > 0] + *) | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_tuple of expression list - (* (E1, ..., En) + (** Expressions [(E1, ..., En)] - Invariant: n >= 2 - *) + Invariant: [n >= 2] + *) | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) + (** [Pexp_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] + *) | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] + *) | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + + Invariant: [n > 0] + *) + | Pexp_field of expression * Longident.t loc (** [E.l] *) | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) + (** [E1.l <- E2] *) + | Pexp_array of expression list (** [[| E1; ...; En |]] *) | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) + (** [if E1 then E2 else E3] *) + | Pexp_sequence of expression * expression (** [E1; E2] *) + | Pexp_while of expression * expression (** [while E1 do E2 done] *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) + (** [Pexp_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. + *) + | Pexp_send of expression * label loc (** [E # m] *) + | Pexp_new of Longident.t loc (** [new M.c] *) + | Pexp_setinstvar of label loc * expression (** [x <- 2] *) | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) + (** [{< x1 = E1; ...; xn = En >}] *) | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) + (** [let module M = ME in E] *) | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) + (** [let exception C in E] *) | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) + (** [assert E]. + + Note: [assert false] is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (** [lazy E] *) | Pexp_poly of expression * core_type option - (* Used for method bodies. + (** Used for method bodies. - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete}[Cfk_concrete]} for methods (not + values). *) + | Pexp_object of class_structure (** [object ... end] *) + | Pexp_newtype of string loc * expression (** [fun (type t) -> E] *) | Pexp_pack of module_expr - (* (module ME) + (** [(module ME)]. - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) + (** - [M.(E)] + - [let open M in E] + - [let open! M in E] *) | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) + and case (*IF_CURRENT = Parsetree.case *) = { pc_lhs: pattern; pc_guard: expression option; pc_rhs: expression; } + (** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) and letop (*IF_CURRENT = Parsetree.letop *) = { @@ -456,53 +485,68 @@ pbop_loc : Location.t; } - (* Value descriptions *) + (** {2 Value descriptions} *) and value_description (*IF_CURRENT = Parsetree.value_description *) = { pval_name: string loc; pval_type: core_type; pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc: Location.t; } + (** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] + *) -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) + (** {2 Type declarations} *) and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = { ptype_name: string loc; ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) + (** [('a1,...'an) t] *) ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) ptype_loc: Location.t; } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) + (** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. + *) and type_kind (*IF_CURRENT = Parsetree.type_kind *) = | Ptype_abstract | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (** Invariant: non-empty list *) | Ptype_open and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = @@ -511,13 +555,17 @@ pld_mutable: mutable_flag; pld_type: core_type; pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) + pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) } + (** + - [{ ...; l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. *) and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = @@ -527,21 +575,25 @@ pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) + pcd_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) } and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = | Pcstr_tuple of core_type list | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [args = Pcstr_record [...]]. + *) and type_extension (*IF_CURRENT = Parsetree.type_extension *) = { @@ -550,100 +602,110 @@ ptyext_constructors: extension_constructor list; ptyext_private: private_flag; ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) } -(* - type t += ... -*) + (** + Definition of new extensions constructors for the extensive sum type [t] + ([type t += ...]). + *) and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = { pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (** [C of ... [\@id1] [\@id2]] *) } - (* exception E *) and type_exception (*IF_CURRENT = Parsetree.type_exception *) = { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } + (** Definition of a new exception ([exception E]). *) and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of string loc list * constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([], [T1; ...; Tn], None) - | C: T0 ([], [], Some T0) - | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) - | C: 'a... . T1... -> T0 (['a;...]; [T1;...], Some T0) - *) + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None].}} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) | Pext_rebind of Longident.t loc - (* - | C = D - *) + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) (** {1 Class language} *) - - (* Type expressions for the class language *) + (** {2 Type expressions for the class language} *) and class_type (*IF_CURRENT = Parsetree.class_type *) = { pcty_desc: class_type_desc; pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) + pcty_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) + (** - [c] + - [['a1, ..., 'an] c] *) + | Pcty_signature of class_signature (** [object ... end] *) | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) + (** [Pcty_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. + *) + | Pcty_extension of extension (** [%id] *) + | Pcty_open of open_description * class_type (** [let open M in CT] *) and class_signature (*IF_CURRENT = Parsetree.class_signature *) = { pcsig_self: core_type; pcsig_fields: class_type_field list; } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) + (** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[Ptyp_any]} *) and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = { pctf_desc: class_type_field_desc; pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) + pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) } and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) + | Pctf_inherit of class_type (** [inherit CT] *) | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) + (** [val x: T] *) + | Pctf_method of (label loc * private_flag * virtual_flag * core_type) + (** [method x: T] + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. + *) + | Pctf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pctf_attribute of attribute (** [[\@\@\@id]] *) + | Pctf_extension of extension (** [[%%id]] *) and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = { @@ -652,98 +714,126 @@ pci_name: string loc; pci_expr: 'a; pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... + (** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] - Also used for "class type" declaration. + They are also used for "class type" declaration. *) and class_description = class_type class_infos and class_type_declaration = class_type class_infos - (* Value expressions for the class language *) + (** {2 Value expressions for the class language} *) and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } + { + pcl_desc: class_expr_desc; + pcl_loc: Location.t; + pcl_attributes: attributes; (** [... [\@id1] [\@id2]] *) + } and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) + (** [c] and [['a1, ..., 'an] c] *) + | Pcl_structure of class_structure (** [object ... end] *) | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [CE ~l1:E1 ... ~ln:En]. + [li] can be empty (non labeled argument) or start with [?] + (optional argument). - Invariant: n > 0 - *) + Invariant: [n > 0] + *) | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pcl_constraint of class_expr * class_type (** [(CE : CT)] *) + | Pcl_extension of extension (** [[%id]] *) + | Pcl_open of open_description * class_expr (** [let open M in CE] *) and class_structure (*IF_CURRENT = Parsetree.class_structure *) = { pcstr_self: pattern; pcstr_fields: class_field list; } - (* object(selfpat) ... end - object ... end (self = Ppat_any) + (** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[Ppat_any]} *) and class_field (*IF_CURRENT = Parsetree.class_field *) = { pcf_desc: class_field_desc; pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) + pcf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) } and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x + (** [Pcf_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] *) | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} *) | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}) + *) + | Pcf_constraint of (core_type * core_type) (** [constraint T1 = T2] *) + | Pcf_initializer of expression (** [initializer E] *) + | Pcf_attribute of attribute (** [[\@\@\@id]] *) + | Pcf_extension of extension (** [[%%id]] *) and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = | Cfk_virtual of core_type @@ -752,38 +842,31 @@ and class_declaration = class_expr class_infos (** {1 Module language} *) - - (* Type expressions for the module language *) + (** {2 Type expressions for the module language} *) and module_type (*IF_CURRENT = Parsetree.module_type *) = { pmty_desc: module_type_desc; pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) + pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) + | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [S] *) + | Pmty_signature of signature (** [sig ... end] *) | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) + (** [functor(X : MT1) -> MT2] *) + | Pmty_with of module_type * with_constraint list (** [MT with ...] *) + | Pmty_typeof of module_expr (** [module type of ME] *) + | Pmty_extension of extension (** [[%id]] *) + | Pmty_alias of Longident.t loc (** [(module M)] *) and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) + | Unit (** [()] *) | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) and signature = signature_item list @@ -795,69 +878,61 @@ and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) + (** - [val x: T] + - [external x: T = "s1" ... "sn"] + *) | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) + (** [type t1 = ... and ... and tn = ...] *) | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) + (** [type t1 := ... and ... and tn := ...] *) + | Psig_typext of type_extension (** [type t1 += ...] *) + | Psig_exception of type_exception (** [exception C of T] *) + | Psig_module of module_declaration (** [module X = M] and [module X : MT] *) + | Psig_modsubst of module_substitution (** [module X := M] *) | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) + (** [module rec X1 : MT1 and ... and Xn : MTn] *) | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) + (** [module type S = MT] and [module type S] *) | Psig_modtypesubst of module_type_declaration - (* module type S := ... *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) + (** [module type S := ...] *) + | Psig_open of open_description (** [open X] *) + | Psig_include of include_description (** [include MT] *) | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) + (** [class c1 : ... and ... and cn : ...] *) | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) + (** [class type ct1 = ... and ... and ctn = ...] *) + | Psig_attribute of attribute (** [[\@\@\@id]] *) + | Psig_extension of extension * attributes (** [[%%id]] *) and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = { pmd_name: string option loc; pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pmd_loc: Location.t; } - (* S : MT *) + (** Values of type [module_declaration] represents [S : MT] *) and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = { pms_name: string loc; pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pms_loc: Location.t; } + (** Values of type [module_substitution] represents [S := M] *) and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = { pmtd_name: string loc; pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pmtd_loc: Location.t; } - (* S = MT - S (abstract module type declaration, pmtd_type = None) + (** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. *) and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = @@ -867,19 +942,24 @@ popen_loc: Location.t; popen_attributes: attributes; } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh + (** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} *) and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) + (** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) + (** Values of type [open_declaration] represents: + - [open M.N] + - [open M(N).O] + - [open struct ... end] *) and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = { @@ -889,52 +969,46 @@ } and include_description = module_type include_infos - (* include MT *) + (** Values of type [include_description] represents [include MT] *) and include_declaration = module_expr include_infos - (* include ME *) + (** Values of type [include_declaration] represents [include ME] *) and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... + (** [with type X.t = ...] - Note: the last component of the longident must match - the name of the type_declaration. *) + Note: the last component of the longident must match + the name of the type_declaration. *) | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) + (** [with module X.Y = Z] *) | Pwith_modtype of Longident.t loc * module_type - (* with module type X.Y = Z *) + (** [with module type X.Y = Z] *) | Pwith_modtypesubst of Longident.t loc * module_type - (* with module type X.Y := sig end *) + (** [with module type X.Y := sig end] *) | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) + (** [with type X.t := ..., same format as [Pwith_type]] *) | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) + (** [with module X.Y := Z] *) - (* Value expressions for the module language *) + (** {2 Value expressions for the module language} *) and module_expr (*IF_CURRENT = Parsetree.module_expr *) = { pmod_desc: module_expr_desc; pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) + pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) + | Pmod_ident of Longident.t loc (** [X] *) + | Pmod_structure of structure (** [struct ... end] *) | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) + (** [functor(X : MT1) -> ME] *) + | Pmod_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) + | Pmod_unpack of expression (** [(val E)] *) + | Pmod_extension of extension (** [[%id]] *) and structure = structure_item list @@ -945,40 +1019,35 @@ } and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) + | Pstr_eval of expression * attributes (** [E] *) | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) + (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) + (** - [val x: T] + - [external x: T = "s1" ... "sn" ]*) | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) + (** [type t1 = ... and ... and tn = ...] *) + | Pstr_typext of type_extension (** [type t1 += ...] *) | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) + (** - [exception C of T] + - [exception C = M.X] *) + | Pstr_module of module_binding (** [module X = ME] *) | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) + (** [module rec X1 = ME1 and ... and Xn = MEn] *) + | Pstr_modtype of module_type_declaration (** [module type S = MT] *) + | Pstr_open of open_declaration (** [open X] *) | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) + (** [class c1 = ... and ... and cn = ...] *) | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) + (** [class type ct1 = ... and ... and ctn = ...] *) + | Pstr_include of include_declaration (** [include ME] *) + | Pstr_attribute of attribute (** [[\@\@\@id]] *) + | Pstr_extension of extension * attributes (** [[%%id]] *) and value_binding (*IF_CURRENT = Parsetree.value_binding *) = { @@ -995,28 +1064,27 @@ pmb_attributes: attributes; pmb_loc: Location.t; } - (* X = ME *) + (** Values of type [module_binding] represents [module X = ME] *) (** {1 Toplevel} *) - (* Toplevel phrases *) + (** {2 Toplevel phrases} *) type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; + pdir_name: string loc; + pdir_arg: directive_argument option; + pdir_loc: Location.t; } and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; + pdira_desc: directive_argument_desc; + pdira_loc: Location.t; } and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = diff -Nru ppxlib-0.24.0/astlib/ast_500.ml ppxlib-0.27.0/astlib/ast_500.ml --- ppxlib-0.24.0/astlib/ast_500.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/astlib/ast_500.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,14 @@ +(* The only difference between 4.14 and 5.0 from a Parsetree point of view are the magic numbers *) + +module Asttypes = struct + include Ast_414.Asttypes +end + +module Parsetree = struct + include Ast_414.Parsetree +end + +module Config = struct + let ast_impl_magic_number = "Caml1999M032" + let ast_intf_magic_number = "Caml1999N032" +end diff -Nru ppxlib-0.24.0/astlib/astlib.ml ppxlib-0.27.0/astlib/astlib.ml --- ppxlib-0.24.0/astlib/astlib.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/astlib.ml 2022-06-14 18:16:33.000000000 +0000 @@ -35,6 +35,7 @@ module Ast_412 = Ast_412 module Ast_413 = Ast_413 module Ast_414 = Ast_414 +module Ast_500 = Ast_500 (*$*) (* Manual migration between versions *) @@ -67,6 +68,8 @@ module Migrate_413_412 = Migrate_413_412 module Migrate_413_414 = Migrate_413_414 module Migrate_414_413 = Migrate_414_413 +module Migrate_414_500 = Migrate_414_500 +module Migrate_500_414 = Migrate_500_414 (*$*) (* Compiler modules *) diff -Nru ppxlib-0.24.0/astlib/cinaps/astlib_cinaps_helpers.ml ppxlib-0.27.0/astlib/cinaps/astlib_cinaps_helpers.ml --- ppxlib-0.24.0/astlib/cinaps/astlib_cinaps_helpers.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/cinaps/astlib_cinaps_helpers.ml 2022-06-14 18:16:33.000000000 +0000 @@ -20,6 +20,7 @@ ("412", "4.12"); ("413", "4.13"); ("414", "4.14"); + ("500", "5.00"); ] let foreach_version f = diff -Nru ppxlib-0.24.0/astlib/config/gen.ml ppxlib-0.27.0/astlib/config/gen.ml --- ppxlib-0.24.0/astlib/config/gen.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/config/gen.ml 2022-06-14 18:16:33.000000000 +0000 @@ -23,6 +23,9 @@ | 4, 12 -> "412" | 4, 13 -> "413" | 4, 14 -> "414" + | 5, 0 -> + "414" + (* Ast_500 aliases Ast_414, since the AST hasn't changed between those two *) | _ -> Printf.eprintf "Unkown OCaml version %s\n" ocaml_version_str; exit 1) diff -Nru ppxlib-0.24.0/astlib/migrate_402_403.ml ppxlib-0.27.0/astlib/migrate_402_403.ml --- ppxlib-0.24.0/astlib/migrate_402_403.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_402_403.ml 2022-06-14 18:16:33.000000000 +0000 @@ -988,7 +988,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true and type_declarations types = @@ -1017,9 +1016,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_403_402.ml ppxlib-0.27.0/astlib/migrate_403_402.ml --- ppxlib-0.24.0/astlib/migrate_403_402.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_403_402.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1003,7 +1003,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true and type_declarations recflag types = @@ -1043,9 +1042,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_403_404.ml ppxlib-0.27.0/astlib/migrate_403_404.ml --- ppxlib-0.24.0/astlib/migrate_403_404.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_403_404.ml 2022-06-14 18:16:33.000000000 +0000 @@ -972,7 +972,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -992,9 +991,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_404_403.ml ppxlib-0.27.0/astlib/migrate_404_403.ml --- ppxlib-0.24.0/astlib/migrate_404_403.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_404_403.ml 2022-06-14 18:16:33.000000000 +0000 @@ -980,7 +980,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1000,9 +999,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_404_405.ml ppxlib-0.27.0/astlib/migrate_404_405.ml --- ppxlib-0.24.0/astlib/migrate_404_405.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_404_405.ml 2022-06-14 18:16:33.000000000 +0000 @@ -987,7 +987,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1007,9 +1006,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_405_404.ml ppxlib-0.27.0/astlib/migrate_405_404.ml --- ppxlib-0.24.0/astlib/migrate_405_404.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_405_404.ml 2022-06-14 18:16:33.000000000 +0000 @@ -986,7 +986,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1006,9 +1005,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_405_406.ml ppxlib-0.27.0/astlib/migrate_405_406.ml --- ppxlib-0.24.0/astlib/migrate_405_406.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_405_406.ml 2022-06-14 18:16:33.000000000 +0000 @@ -989,7 +989,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1009,9 +1008,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_406_405.ml ppxlib-0.27.0/astlib/migrate_406_405.ml --- ppxlib-0.24.0/astlib/migrate_406_405.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_406_405.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1001,7 +1001,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1021,9 +1020,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_406_407.ml ppxlib-0.27.0/astlib/migrate_406_407.ml --- ppxlib-0.24.0/astlib/migrate_406_407.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_406_407.ml 2022-06-14 18:16:33.000000000 +0000 @@ -997,7 +997,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1017,9 +1016,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_407_406.ml ppxlib-0.27.0/astlib/migrate_407_406.ml --- ppxlib-0.24.0/astlib/migrate_407_406.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_407_406.ml 2022-06-14 18:16:33.000000000 +0000 @@ -997,7 +997,6 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let rec copy_toplevel_phrase : @@ -1017,9 +1016,6 @@ | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_407_408.ml ppxlib-0.27.0/astlib/migrate_407_408.ml --- ppxlib-0.24.0/astlib/migrate_407_408.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_407_408.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1119,13 +1119,9 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_408_407.ml ppxlib-0.27.0/astlib/migrate_408_407.ml --- ppxlib-0.24.0/astlib/migrate_408_407.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_408_407.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1101,13 +1101,9 @@ { To.Asttypes.txt = f0 txt; To.Asttypes.loc = copy_location loc } and copy_location : Location.t -> Location.t = fun x -> x - and copy_bool : bool -> bool = function false -> false | true -> true let copy_cases x = List.map copy_case x - let copy_pat = copy_pattern - let copy_expr = copy_expression - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_409_410.ml ppxlib-0.27.0/astlib/migrate_409_410.ml --- ppxlib-0.24.0/astlib/migrate_409_410.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_409_410.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1187,7 +1187,5 @@ and copy_location : Location.t -> Location.t = fun x -> x let copy_expr = copy_expression - let copy_pat = copy_pattern - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_410_409.ml ppxlib-0.27.0/astlib/migrate_410_409.ml --- ppxlib-0.24.0/astlib/migrate_410_409.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_410_409.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1209,7 +1209,5 @@ and copy_location : Location.t -> Location.t = fun x -> x let copy_expr = copy_expression - let copy_pat = copy_pattern - let copy_typ = copy_core_type diff -Nru ppxlib-0.24.0/astlib/migrate_414_500.ml ppxlib-0.27.0/astlib/migrate_414_500.ml --- ppxlib-0.24.0/astlib/migrate_414_500.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_414_500.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,40 @@ +module From = Ast_414 +module To = Ast_500 + +let copy_structure : Ast_414.Parsetree.structure -> Ast_500.Parsetree.structure + = + fun x -> x + +let copy_signature : Ast_414.Parsetree.signature -> Ast_500.Parsetree.signature + = + fun x -> x + +let copy_toplevel_phrase : + Ast_414.Parsetree.toplevel_phrase -> Ast_500.Parsetree.toplevel_phrase = + fun x -> x + +let copy_core_type : Ast_414.Parsetree.core_type -> Ast_500.Parsetree.core_type + = + fun x -> x + +let copy_expression : + Ast_414.Parsetree.expression -> Ast_500.Parsetree.expression = + fun x -> x + +let copy_pattern : Ast_414.Parsetree.pattern -> Ast_500.Parsetree.pattern = + fun x -> x + +let copy_case : Ast_414.Parsetree.case -> Ast_500.Parsetree.case = fun x -> x + +let copy_type_declaration : + Ast_414.Parsetree.type_declaration -> Ast_500.Parsetree.type_declaration = + fun x -> x + +let copy_type_extension : + Ast_414.Parsetree.type_extension -> Ast_500.Parsetree.type_extension = + fun x -> x + +let copy_extension_constructor : + Ast_414.Parsetree.extension_constructor -> + Ast_500.Parsetree.extension_constructor = + fun x -> x diff -Nru ppxlib-0.24.0/astlib/migrate_500_414.ml ppxlib-0.27.0/astlib/migrate_500_414.ml --- ppxlib-0.24.0/astlib/migrate_500_414.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/astlib/migrate_500_414.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,40 @@ +module From = Ast_500 +module To = Ast_414 + +let copy_structure : Ast_500.Parsetree.structure -> Ast_414.Parsetree.structure + = + fun x -> x + +let copy_signature : Ast_500.Parsetree.signature -> Ast_414.Parsetree.signature + = + fun x -> x + +let copy_toplevel_phrase : + Ast_500.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase = + fun x -> x + +let copy_core_type : Ast_500.Parsetree.core_type -> Ast_414.Parsetree.core_type + = + fun x -> x + +let copy_expression : + Ast_500.Parsetree.expression -> Ast_414.Parsetree.expression = + fun x -> x + +let copy_pattern : Ast_500.Parsetree.pattern -> Ast_414.Parsetree.pattern = + fun x -> x + +let copy_case : Ast_500.Parsetree.case -> Ast_414.Parsetree.case = fun x -> x + +let copy_type_declaration : + Ast_500.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration = + fun x -> x + +let copy_type_extension : + Ast_500.Parsetree.type_extension -> Ast_414.Parsetree.type_extension = + fun x -> x + +let copy_extension_constructor : + Ast_500.Parsetree.extension_constructor -> + Ast_414.Parsetree.extension_constructor = + fun x -> x diff -Nru ppxlib-0.24.0/astlib/pprintast.ml ppxlib-0.27.0/astlib/pprintast.ml --- ppxlib-0.24.0/astlib/pprintast.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/pprintast.ml 2022-06-14 18:16:33.000000000 +0000 @@ -21,13 +21,17 @@ (* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) (* TODO more fine-grained precedence pretty-printing *) -open Ast_412 +open Ast_414 open Asttypes open Format open Location open Longident open Parsetree +module Option = struct + let value t ~default = match t with None -> default | Some x -> x +end + let varify_type_constructors var_names t = let check_variable vl loc v = if List.mem v vl then @@ -128,15 +132,10 @@ | _ -> `Normal let is_infix = function `Infix _ -> true | _ -> false - let is_mixfix = function `Mixfix _ -> true | _ -> false - let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false - let first_is c str = str <> "" && str.[0] = c - let last_is c str = str <> "" && str.[String.length str - 1] = c - let first_is_in cs str = str <> "" && List.mem str.[0] cs (* which identifiers are in fact operators needing parentheses *) @@ -148,6 +147,7 @@ (* some infixes need spaces around parens to avoid clashes with comment syntax *) let needs_spaces txt = first_is '*' txt || last_is '*' txt +let string_loc ppf x = fprintf ppf "%s" x.txt (* add parentheses to binders when they are in fact infix or prefix operators *) let protect_ident ppf txt = @@ -223,11 +223,8 @@ type ctxt = { pipe : bool; semi : bool; ifthenelse : bool } let reset_ctxt = { pipe = false; semi = false; ifthenelse = false } - let under_pipe ctxt = { ctxt with pipe = true } - let under_semi ctxt = { ctxt with semi = true } - let under_ifthenelse ctxt = { ctxt with ifthenelse = true } (* let reset_semi ctxt = { ctxt with semi=false } @@ -322,7 +319,6 @@ (* trailing space*) let mutable_flag f = function Immutable -> () | Mutable -> pp f "mutable@;" - let virtual_flag f = function Concrete -> () | Virtual -> pp f "virtual@;" (* trailing space added *) @@ -337,9 +333,7 @@ | Downto -> pp f "downto@ " let private_flag f = function Public -> () | Private -> pp f "private@ " - let iter_loc f ctxt { txt; loc = _ } = f ctxt txt - let constant_string f s = pp f "%S" s let tyvar ppf s = @@ -350,7 +344,6 @@ else Format.fprintf ppf "'%s" s let tyvar_loc f str = tyvar f str.txt - let string_quot f x = pp f "`%s" x (* c ['a,'b] *) @@ -478,12 +471,6 @@ (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) and pattern ctxt f x = - let rec list_of_pattern acc = function - (* only consider ((A|B)|C)*) - | { ppat_desc = Ppat_or (p1, p2); ppat_attributes = [] } -> - list_of_pattern (p2 :: acc) p1 - | x -> x :: acc - in if x.ppat_attributes <> [] then pp f "((%a)%a)" (pattern ctxt) { x with ppat_attributes = [] } @@ -491,13 +478,20 @@ else match x.ppat_desc with | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) - | Ppat_or _ -> - (* *) - pp f "@[%a@]" - (list ~sep:"@,|" (pattern ctxt)) - (list_of_pattern [] x) - | _ -> pattern1 ctxt f x + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt + | _ -> pattern_or ctxt f x + +and pattern_or ctxt f x = + let rec left_associative x acc = + match x with + | { ppat_desc = Ppat_or (p1, p2); ppat_attributes = [] } -> + left_associative p1 (p2 :: acc) + | x -> x :: acc + in + match left_associative x [] with + | [] -> assert false + | [ x ] -> pattern1 ctxt f x + | orpats -> pp f "@[%a@]" (list ~sep:"@ | " (pattern1 ctxt)) orpats and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = let rec pattern_list_helper f = function @@ -505,7 +499,7 @@ ppat_desc = Ppat_construct ( { txt = Lident "::"; _ }, - Some { ppat_desc = Ppat_tuple [ pat1; pat2 ]; _ } ); + Some ([], { ppat_desc = Ppat_tuple [ pat1; pat2 ]; _ }) ); ppat_attributes = []; } -> pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) @@ -523,7 +517,12 @@ txt = Lident "::" then pp f "%a" pattern_list_helper x else match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | Some ([], x) -> + pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | Some (vl, x) -> + pp f "%a@ (type %a)@;%a" longident_loc li + (list ~sep:"@ " string_loc) + vl (simple_pattern ctxt) x | None -> pp f "%a" longident_loc li) | _ -> simple_pattern ctxt f x @@ -531,7 +530,7 @@ if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with - | Ppat_construct ({ txt = Lident (("()" | "[]") as x); _ }, _) -> + | Ppat_construct ({ txt = Lident (("()" | "[]") as x); _ }, None) -> pp f "%s" x | Ppat_any -> pp f "_" | Ppat_var { txt; _ } -> protect_ident f txt @@ -559,14 +558,14 @@ | Ppat_variant (l, None) -> pp f "`%s" l | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" (simple_pattern ctxt) p | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p | Ppat_extension e -> extension ctxt f e | Ppat_open (lid, p) -> let with_paren = match p.ppat_desc with | Ppat_array _ | Ppat_record _ - | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, _) -> + | Ppat_construct ({ txt = Lident ("()" | "[]"); _ }, None) -> false | _ -> true in @@ -607,8 +606,8 @@ ( { pexp_desc = Pexp_ident { txt = id; _ }; pexp_attributes = []; _ }, args ) when List.for_all (fun (lab, _) -> lab = Nolabel) args -> ( - let print_indexop a path_prefix assign left right print_index indices - rem_args = + let print_indexop a path_prefix assign left sep right print_index + indices rem_args = let print_path ppf = function | None -> () | Some m -> pp ppf ".%a" longident m @@ -616,15 +615,12 @@ match (assign, rem_args) with | false, [] -> pp f "@[%a%a%s%a%s@]" (simple_expr ctxt) a print_path path_prefix - left - (list ~sep:"," print_index) - indices right; + left (list ~sep print_index) indices right; true | true, [ v ] -> pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" (simple_expr ctxt) a print_path - path_prefix left - (list ~sep:"," print_index) - indices right (simple_expr ctxt) v; + path_prefix left (list ~sep print_index) indices right + (simple_expr ctxt) v; true | _ -> false in @@ -637,25 +633,31 @@ let print = print_indexop a None assign in match (path, other_args) with | Lident "Array", i :: rest -> - print ".(" ")" (expression ctxt) [ i ] rest + print ".(" "" ")" (expression ctxt) [ i ] rest | Lident "String", i :: rest -> - print ".[" "]" (expression ctxt) [ i ] rest + print ".[" "" "]" (expression ctxt) [ i ] rest | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "}" (simple_expr ctxt) [ i1 ] rest + print ".{" "," "}" (simple_expr ctxt) [ i1 ] rest | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "}" (simple_expr ctxt) [ i1; i2 ] rest + print ".{" "," "}" (simple_expr ctxt) [ i1; i2 ] rest | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "}" (simple_expr ctxt) [ i1; i2; i3 ] rest + print ".{" "," "}" (simple_expr ctxt) [ i1; i2; i3 ] rest | ( Ldot (Lident "Bigarray", "Genarray"), { pexp_desc = Pexp_array indexes; pexp_attributes = [] } :: rest ) -> - print ".{" "}" (simple_expr ctxt) indexes rest + print ".{" "," "}" (simple_expr ctxt) indexes rest | _ -> false) | (Lident s | Ldot (_, s)), a :: i :: rest when first_is '.' s -> (* extract operator: assignment operators end with [right_bracket ^ "<-"], access operators end with [right_bracket] directly *) + let multi_indices = String.contains s ';' in + let i = + match i.pexp_desc with + | Pexp_array l when multi_indices -> l + | _ -> [ i ] + in let assign = last_is '-' s in let kind = (* extract the right end bracket *) @@ -673,8 +675,9 @@ match id with Ldot (m, _) -> Some m | _ -> None in let left = String.sub s 0 (1 + String.index s left) in - print_indexop a path_prefix assign left right (expression ctxt) - [ i ] rest + print_indexop a path_prefix assign left ";" right + (if multi_indices then expression ctxt else simple_expr ctxt) + i rest | _ -> false) | _ -> false @@ -686,6 +689,7 @@ else match x.pexp_desc with | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + | Pexp_newtype _ when ctxt.pipe || ctxt.semi -> paren true (expression reset_ctxt) f x | (Pexp_ifthenelse _ | Pexp_sequence _) when ctxt.ifthenelse -> @@ -697,6 +701,8 @@ | Pexp_fun (l, e0, p, e) -> pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p) (expression ctxt) e + | Pexp_newtype (lid, e) -> + pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt (expression ctxt) e | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) @@ -799,7 +805,7 @@ pp f "@[{<%a>}@]" (list string_x_expression ~sep:";") l | Pexp_letmodule (s, me, e) -> pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" - (match s.txt with None -> "_" | Some s -> s) + (Option.value s.txt ~default:"_") (module_expr reset_ctxt) me (expression ctxt) e | Pexp_letexception (cd, e) -> pp f "@[let@ exception@ %a@ in@ %a@]" @@ -863,8 +869,6 @@ (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) | Pexp_constant c -> constant f c | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e | Pexp_tuple l -> pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l | Pexp_constraint (e, ct) -> @@ -907,7 +911,6 @@ | _ -> paren true (expression ctxt) f x and attributes ctxt f l = List.iter (attribute ctxt f) l - and item_attributes ctxt f l = List.iter (item_attribute ctxt f) l and attribute ctxt f a = @@ -1120,27 +1123,31 @@ (module_type ctxt) mt1 (module_type ctxt) mt2) | Pmty_with (mt, []) -> module_type ctxt f mt | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ ptype_params = ls; _ } as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2 - | Pwith_typesubst (li, ({ ptype_params = ls; _ } as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 - in pp f "@[%a@ with@ %a@]" (module_type1 ctxt) mt - (list with_constraint ~sep:"@ and@ ") + (list (with_constraint ctxt) ~sep:"@ and@ ") l | _ -> module_type1 ctxt f x +and with_constraint ctxt f = function + | Pwith_type (li, ({ ptype_params = ls; _ } as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2 + | Pwith_modtype (li, mty) -> + pp f "module type %a =@ %a" longident_loc li (module_type ctxt) mty + | Pwith_typesubst (li, ({ ptype_params = ls; _ } as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + | Pwith_modtypesubst (li, mty) -> + pp f "module type %a :=@ %a" longident_loc li (module_type ctxt) mty + and module_type1 ctxt f x = if x.pmty_attributes <> [] then module_type ctxt f x else @@ -1195,11 +1202,11 @@ _; } as pmd) -> pp f "@[module@ %s@ =@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (Option.value pmd.pmd_name.txt ~default:"_") longident_loc alias (item_attributes ctxt) pmd.pmd_attributes | Psig_module pmd -> pp f "@[module@ %s@ :@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (Option.value pmd.pmd_name.txt ~default:"_") (module_type ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes | Psig_modsubst pms -> @@ -1221,6 +1228,13 @@ pp_print_space f (); pp f "@ =@ %a" (module_type ctxt) mt) md (item_attributes ctxt) attrs + | Psig_modtypesubst { pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs } + -> + let md = + match md with None -> assert false (* ast invariant *) | Some mt -> mt + in + pp f "@[module@ type@ %s@ :=@ %a@]%a" s.txt (module_type ctxt) md + (item_attributes ctxt) attrs | Psig_class_type l -> class_type_declaration_list ctxt f l | Psig_recmodule decls -> let rec string_x_module_type_list f ?(first = true) l = @@ -1229,12 +1243,12 @@ | pmd :: tl -> if not first then pp f "@ @[and@ %s:@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (Option.value pmd.pmd_name.txt ~default:"_") (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes else pp f "@[module@ rec@ %s:@ %a@]%a" - (match pmd.pmd_name.txt with None -> "_" | Some s -> s) + (Option.value pmd.pmd_name.txt ~default:"_") (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes; string_x_module_type_list f ~first:false tl @@ -1262,7 +1276,7 @@ | Pmod_functor (Unit, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me | Pmod_functor (Named (s, mt), me) -> pp f "functor@ (%s@ :@ %a)@;->@;%a" - (match s.txt with None -> "_" | Some s -> s) + (Option.value s.txt ~default:"_") (module_type ctxt) mt (module_expr ctxt) me | Pmod_apply (me1, me2) -> pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 @@ -1390,8 +1404,18 @@ xs and binding_op ctxt f x = - pp f "@[<2>%s %a@;=@;%a@]" x.pbop_op.txt (pattern ctxt) x.pbop_pat - (expression ctxt) x.pbop_exp + match (x.pbop_pat, x.pbop_exp) with + | ( { ppat_desc = Ppat_var { txt = pvar; _ }; ppat_attributes = []; _ }, + { + pexp_desc = Pexp_ident { txt = Lident evar; _ }; + pexp_attributes = []; + _; + } ) + when pvar = evar -> + pp f "@[<2>%s %s@]" x.pbop_op.txt evar + | pat, exp -> + pp f "@[<2>%s %a@;=@;%a@]" x.pbop_op.txt (pattern ctxt) pat + (expression ctxt) exp and structure_item ctxt f x = match x.pstr_desc with @@ -1411,13 +1435,13 @@ | Unit -> pp f "()" | Named (s, mt) -> pp f "(%s:%a)" - (match s.txt with None -> "_" | Some s -> s) + (Option.value s.txt ~default:"_") (module_type ctxt) mt); module_helper me' | me -> me in pp f "@[module %s%a@]%a" - (match x.pmb_name.txt with None -> "_" | Some s -> s) + (Option.value x.pmb_name.txt ~default:"_") (fun f me -> let me = module_helper me in match me with @@ -1492,12 +1516,12 @@ let aux f = function | { pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb -> pp f "@[@ and@ %s:%a@ =@ %a@]%a" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (Option.value pmb.pmb_name.txt ~default:"_") (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes | pmb -> pp f "@[@ and@ %s@ =@ %a@]%a" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (Option.value pmb.pmb_name.txt ~default:"_") (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt) pmb.pmb_attributes in @@ -1505,14 +1529,14 @@ | ({ pmb_expr = { pmod_desc = Pmod_constraint (expr, typ) } } as pmb) :: l2 -> pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (Option.value pmb.pmb_name.txt ~default:"_") (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) l2 | pmb :: l2 -> pp f "@[@[module@ rec@ %s@ =@ %a@]%a@ %a@]" - (match pmb.pmb_name.txt with None -> "_" | Some s -> s) + (Option.value pmb.pmb_name.txt ~default:"_") (module_expr ctxt) pmb.pmb_expr (item_attributes ctxt) pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) @@ -1573,7 +1597,11 @@ let constructor_declaration f pcd = pp f "|@;"; constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + ( pcd.pcd_name.txt, + pcd.pcd_vars, + pcd.pcd_args, + pcd.pcd_res, + pcd.pcd_attributes ) in let repr f = let intro f = if x.ptype_manifest = None then () else pp f "@;=" in @@ -1611,8 +1639,13 @@ (list ~sep:"" extension_constructor) x.ptyext_constructors (item_attributes ctxt) x.ptyext_attributes -and constructor_declaration ctxt f (name, args, res, attrs) = +and constructor_declaration ctxt f (name, vars, args, res, attrs) = let name = match name with "::" -> "(::)" | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs + in match res with | None -> pp f "%s%a@;%a" name @@ -1623,7 +1656,7 @@ | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l) args (attributes ctxt) attrs | Some r -> - pp f "%s:@;%a@;%a" name + pp f "%s:@;%a%a@;%a" name pp_vars vars (fun f -> function | Pcstr_tuple [] -> core_type1 ctxt f r | Pcstr_tuple l -> @@ -1637,8 +1670,9 @@ and extension_constructor ctxt f x = (* Cf: #7200 *) match x.pext_kind with - | Pext_decl (l, r) -> - constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_decl (v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, l, r, x.pext_attributes) | Pext_rebind li -> pp f "%s@;=@;%a%a" x.pext_name.txt longident_loc li (attributes ctxt) x.pext_attributes @@ -1709,29 +1743,16 @@ pp_print_newline f () let core_type = core_type reset_ctxt - let pattern = pattern reset_ctxt - let signature = signature reset_ctxt - let structure = structure reset_ctxt - let class_expr = class_expr reset_ctxt - let class_field = class_field reset_ctxt - let class_type = class_type reset_ctxt - let class_signature = class_signature reset_ctxt - let class_type_field = class_type_field reset_ctxt - let module_expr = module_expr reset_ctxt - let module_type = module_type reset_ctxt - let signature_item = signature_item reset_ctxt - let structure_item = structure_item reset_ctxt - let type_declaration = type_declaration reset_ctxt diff -Nru ppxlib-0.24.0/astlib/pprintast.mli ppxlib-0.27.0/astlib/pprintast.mli --- ppxlib-0.24.0/astlib/pprintast.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/astlib/pprintast.mli 2022-06-14 18:16:33.000000000 +0000 @@ -13,45 +13,28 @@ (* *) (**************************************************************************) -open Ast_412 +open Ast_414 type space_formatter = (unit, Format.formatter, unit) format val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit - val expression : Format.formatter -> Parsetree.expression -> unit - val string_of_expression : Parsetree.expression -> string - val top_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit - val core_type : Format.formatter -> Parsetree.core_type -> unit - val pattern : Format.formatter -> Parsetree.pattern -> unit - val signature : Format.formatter -> Parsetree.signature -> unit - val structure : Format.formatter -> Parsetree.structure -> unit - val string_of_structure : Parsetree.structure -> string (* Added in the ppxlib copy *) val class_expr : Format.formatter -> Parsetree.class_expr -> unit - val class_field : Format.formatter -> Parsetree.class_field -> unit - val class_type : Format.formatter -> Parsetree.class_type -> unit - val class_signature : Format.formatter -> Parsetree.class_signature -> unit - val class_type_field : Format.formatter -> Parsetree.class_type_field -> unit - val module_expr : Format.formatter -> Parsetree.module_expr -> unit - val module_type : Format.formatter -> Parsetree.module_type -> unit - val signature_item : Format.formatter -> Parsetree.signature_item -> unit - val structure_item : Format.formatter -> Parsetree.structure_item -> unit - val type_declaration : Format.formatter -> Parsetree.type_declaration -> unit diff -Nru ppxlib-0.24.0/CHANGES.md ppxlib-0.27.0/CHANGES.md --- ppxlib-0.24.0/CHANGES.md 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/CHANGES.md 2022-06-14 18:16:33.000000000 +0000 @@ -1,3 +1,54 @@ +0.27.0 (14/06/2022) +------------------- + +- Update expansion context to leave out value name when multiple are + defined at once. (#351, @ceastlund) + +- Add support for OCaml 5.0 (#348, @pitag-ha) + +- Add `Code_path.enclosing_value` (#349, @ceastlund) + +- Add `Code_path.enclosing_module` (#346, @ceastlund) + +- Expand code generated by `~enclose_intf` and `~enclose_impl` (#345, @ceastlund) + +- Add type annotations to code generated by metaquot (#344, @ceastlund) + +- Fix typo in description field of dune-project (#343, @ceastlund) + +- Fix Ast_pattern.many (#333, @nojb) + +- Fix quoter and optimize identifier quoting (#327, @sim642) + +- Driver, when run with `--check`: Allow `toplevel_printer` attributes (#340, @pitag-ha) + +- Documentation: Add a section on reporting errors by embedding extension nodes + in the AST (#318, @panglesd) + +- Driver: In the case of ppxlib internal errors, embed those errors instead of + raising to return a meaningful AST (#329, @panglesd) + +- API: For each function that could raise a located error, add a function that + return a `result` instead (#329, @panglesd) + +0.26.0 (21/03/2022) +------------------- + +- Bump ppxlib's AST to 4.14/5.00 (#320, @pitag-ha) + +0.25.0 (03/03/2022) +------------------- + +- Added `error_extensionf` function to the `Location` module (#316, @panglesd) + +- Ast patterns: add `drop` and `as` patterns (#313 by @Kakadu, review by @pitag-ha) + +- Fixed a bug resulting in disscarded rewriters in the presence of + instrumentations, as well as a wrong order of rewriting (#296, @panglesd) + +- Driver: Append the last valid AST to the error in case of located exception + when embedding errors (#315, @panglesd) + 0.24.0 (08/12/2021) ------------------- @@ -19,6 +70,7 @@ consider a type declaration recursive if the type appeared inside an attribute payload (#299, @NathanReb) + 0.23.0 (31/08/2021) ------------------- diff -Nru ppxlib-0.24.0/debian/changelog ppxlib-0.27.0/debian/changelog --- ppxlib-0.24.0/debian/changelog 2022-01-28 15:09:35.000000000 +0000 +++ ppxlib-0.27.0/debian/changelog 2022-11-24 13:05:01.000000000 +0000 @@ -1,14 +1,22 @@ -ppxlib (0.24.0-1build2) jammy; urgency=medium +ppxlib (0.27.0-2build1) lunar; urgency=medium - * No-change rebuild for ocaml abi changes. + * Rebuild against new OCAML ABI. - -- Matthias Klose Fri, 28 Jan 2022 16:09:35 +0100 + -- Gianfranco Costamagna Thu, 24 Nov 2022 14:05:01 +0100 -ppxlib (0.24.0-1build1) jammy; urgency=medium +ppxlib (0.27.0-2) unstable; urgency=medium - * No-change rebuild for ocaml abi changes. + * Bump deb-version to get around numbering issue. - -- Matthias Klose Tue, 25 Jan 2022 10:56:55 +0100 + -- Julien Puydt Tue, 11 Oct 2022 20:56:20 +0200 + +ppxlib (0.27.0-1) unstable; urgency=medium + + * New upstream release. + * Fix d/watch. + * Bump Standards-Version to 4.6.1. + + -- Julien Puydt Mon, 15 Aug 2022 15:52:46 +0200 ppxlib (0.24.0-1) unstable; urgency=medium diff -Nru ppxlib-0.24.0/debian/control ppxlib-0.27.0/debian/control --- ppxlib-0.24.0/debian/control 2022-01-20 15:21:22.000000000 +0000 +++ ppxlib-0.27.0/debian/control 2022-10-11 18:56:20.000000000 +0000 @@ -11,7 +11,7 @@ libppx-derivers-ocaml-dev, libsexplib0-ocaml-dev, dh-ocaml -Standards-Version: 4.6.0 +Standards-Version: 4.6.1 Rules-Requires-Root: no Section: ocaml Homepage: https://github.com/ocaml-ppx/ppxlib diff -Nru ppxlib-0.24.0/debian/watch ppxlib-0.27.0/debian/watch --- ppxlib-0.24.0/debian/watch 2022-01-20 15:21:22.000000000 +0000 +++ ppxlib-0.27.0/debian/watch 2022-10-11 18:56:20.000000000 +0000 @@ -1,2 +1,2 @@ version=4 -https://github.com/ocaml-ppx/ppxlib/releases .*-([0-9.]+)\.tbz +https://github.com/ocaml-ppx/ppxlib/tags .*/([0-9.]+)\.tar\.gz diff -Nru ppxlib-0.24.0/doc/conf.py ppxlib-0.27.0/doc/conf.py --- ppxlib-0.24.0/doc/conf.py 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/doc/conf.py 1970-01-01 00:00:00.000000000 +0000 @@ -1,160 +0,0 @@ -# -*- coding: utf-8 -*- -# -# ppxlib documentation build configuration file, created by -# sphinx-quickstart on Sun Aug 12 15:37:30 2018. -# -# This file is execfile()d with the current directory set to its -# containing dir. -# -# Note that not all possible configuration values are present in this -# autogenerated file. -# -# All configuration values have a default; values that are commented out -# serve to show the default. - -# If extensions (or modules to document with autodoc) are in another directory, -# add these directories to sys.path here. If the directory is relative to the -# documentation root, use os.path.abspath to make it absolute, like shown here. -# -# import os -# import sys -# sys.path.insert(0, os.path.abspath('.')) - - -# -- General configuration ------------------------------------------------ - -# If your documentation needs a minimal Sphinx version, state it here. -# -# needs_sphinx = '1.0' - -# Add any Sphinx extension module names here, as strings. They can be -# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom -# ones. -extensions = [] - -# Add any paths that contain templates here, relative to this directory. -templates_path = ['_templates'] - -# The suffix(es) of source filenames. -# You can specify multiple suffix as a list of string: -# -# source_suffix = ['.rst', '.md'] -source_suffix = '.rst' - -# The master toctree document. -master_doc = 'index' - -# General information about the project. -project = u'ppxlib' -copyright = u'2018, Jane Street Group, LLC' -author = u'Jane Street Group, LLC' - -# The language for content autogenerated by Sphinx. Refer to documentation -# for a list of supported languages. -# -# This is also used if you do content translation via gettext catalogs. -# Usually you set "language" from the command line for these cases. -language = None - -# List of patterns, relative to source directory, that match files and -# directories to ignore when looking for source files. -# This patterns also effect to html_static_path and html_extra_path -exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] - -# The name of the Pygments (syntax highlighting) style to use. -pygments_style = 'sphinx' - -# If true, `todo` and `todoList` produce output, else they produce nothing. -todo_include_todos = False - - -# -- Options for HTML output ---------------------------------------------- - -# The theme to use for HTML and HTML Help pages. See the documentation for -# a list of builtin themes. -# -html_theme = 'alabaster' - -# Theme options are theme-specific and customize the look and feel of a theme -# further. For a list of options available for each theme, see the -# documentation. -# -# html_theme_options = {} - -# Add any paths that contain custom static files (such as style sheets) here, -# relative to this directory. They are copied after the builtin static files, -# so a file named "default.css" will overwrite the builtin "default.css". -# html_static_path = ['_static'] - -# Custom sidebar templates, must be a dictionary that maps document names -# to template names. -# -# This is required for the alabaster theme -# refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars -html_sidebars = { - '**': [ - 'relations.html', # needs 'show_related': True theme option to display - 'searchbox.html', - ] -} - - -# -- Options for HTMLHelp output ------------------------------------------ - -# Output file base name for HTML help builder. -htmlhelp_basename = 'ppxlibdoc' - - -# -- Options for LaTeX output --------------------------------------------- - -latex_elements = { - # The paper size ('letterpaper' or 'a4paper'). - # - # 'papersize': 'letterpaper', - - # The font size ('10pt', '11pt' or '12pt'). - # - # 'pointsize': '10pt', - - # Additional stuff for the LaTeX preamble. - # - # 'preamble': '', - - # Latex figure (float) alignment - # - # 'figure_align': 'htbp', -} - -# Grouping the document tree into LaTeX files. List of tuples -# (source start file, target name, title, -# author, documentclass [howto, manual, or own class]). -latex_documents = [ - (master_doc, 'ppxlib.tex', u'ppxlib Documentation', - u'Jane Street Group, LLC', 'manual'), -] - - -# -- Options for manual page output --------------------------------------- - -# One entry per manual page. List of tuples -# (source start file, name, description, authors, manual section). -man_pages = [ - (master_doc, 'ppxlib', u'ppxlib Documentation', - [author], 1) -] - - -# -- Options for Texinfo output ------------------------------------------- - -# Grouping the document tree into Texinfo files. List of tuples -# (source start file, target name, title, author, -# dir menu entry, description, category) -texinfo_documents = [ - (master_doc, 'ppxlib', u'ppxlib Documentation', - author, 'ppxlib', 'A comprehensive toolbox for ppx development.', - 'Miscellaneous'), -] - -import sphinx_rtd_theme - -html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] diff -Nru ppxlib-0.24.0/doc/dune ppxlib-0.27.0/doc/dune --- ppxlib-0.24.0/doc/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/doc/dune 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,2 @@ +(documentation + (package ppxlib)) diff -Nru ppxlib-0.24.0/doc/index.mld ppxlib-0.27.0/doc/index.mld --- ppxlib-0.24.0/doc/index.mld 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/doc/index.mld 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,30 @@ +{0 Ppxlib's user manual} + +{1 Overview} + +This is the user manual and api for ppxlib, the core of the ppx meta-programming +system for {{:https://ocaml.org/}OCaml} and its derivatives such as +{{:https://reasonml.github.io/}Reason}. This manual is aimed at both users and +authors of ppx rewriters and contains everything one should know in order to use +or write ppx rewriters. + +It is assumed in this manual that the user is familiar with the +{{:https://dune.build/}Dune} build system. In particular, all the examples in +this manual referring to the build system will present +{{:https://dune.build/}Dune} configurations files and commands. It is possible +to use ppxlib with other build systems, however this is not covered by this +manual. + +{1 Manual} + +The {{!page-manual}manual} consists of three main sections: + +- {{!page-manual."what-is-ppx"}What is ppx} +- {{!page-manual."ppxlib-for-end-users"}Ppxlib for end users} +- {{!page-manual."ppxlib-for-plugin-authors"}Ppxlib for plugin authors} + +{1 API} + +The API exposes the following modules: + +{!modules: ppxlib ppxlib_ast astlib ppxlib_metaquot Ppxlib_metaquot_lifters Ppxlib_print_diff Ppxlib_runner Ppxlib_runner_as_ppx Stdppx Ppxlib_traverse Ppxlib_traverse_builtins} diff -Nru ppxlib-0.24.0/doc/index.rst ppxlib-0.27.0/doc/index.rst --- ppxlib-0.24.0/doc/index.rst 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/doc/index.rst 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -ppxlib's user manual -==================== - -Overview --------- - -This is the user manual for ppxlib, the core of the ppx -meta-programming system for OCaml_ and its derivatives such as -Reason_. This manual is aimed at both users and authors of ppx -rewriters and contains everything one should know in order to use or -write ppx rewriters. - -It is assumed in this manual that the user is familiar with the Dune_ -build system. In particular, all the examples in this manual referring -to the build system will present Dune_ configurations files and -commands. It is possible to use ppxlib with other build systems, -however this is not covered by this manual. - -.. _OCaml: https://ocaml.org/ -.. _Dune: https://dune.build/ -.. _Reason: https://reasonml.github.io/ - -.. toctree:: - :maxdepth: 2 - :caption: Contents: - - what-is-ppx - ppx-for-end-users - ppx-for-plugin-authors - -Indices and tables ------------------- - -* :ref:`genindex` -* :ref:`modindex` -* :ref:`search` diff -Nru ppxlib-0.24.0/doc/manual.mld ppxlib-0.27.0/doc/manual.mld --- ppxlib-0.24.0/doc/manual.mld 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/doc/manual.mld 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,721 @@ +{0 Ppxlib's manual} + +{1:what-is-ppx What is ppx} + +{2 Overview} + +Ppx is a meta-programming system for the OCaml programming language. It allows +developers to generate code at compile time in a principled way. The +distinguishing feature of ppx is that it is tightly integrated with the OCaml +parser and instead of operating at the text level it operates on the internal +structured representation of the language in the compiler, called the Abstract +Syntax Tree or AST for short. + +A few years ago, the OCaml language was extended with two new constructions: +annotations and extension points. Annotations are arbitrary pieces of +information that can be attached to most parts of the OCaml language. They can +be used to control the behavior of the OCaml compiler, or in some specific cases +to generate code at compile time. + +Extension points are compile time functions. The compiler itself doesn't know +how to interpret them and they must all be rewritten by the ppx system before +the compiler can process input files further. + +Ppxlib mainly supports two ways of generating code at compile time: by expanding +an extension point or by expanding a [[@@deriving ...]] attribute after a type +declaration. + +{2 How does it works?} + +The ppx system is composed of 3 parts: + +- individual ppx rewriters +- ppxlib +- a hook in the compiler + +Individual ppx rewriters are those implemented by various developers to provide +features to end users, such as +{{:https://github.com/janestreet/ppx_expect}ppx_expect} which provides a good +inline testing framework. + +All these rewriters are written against the ppxlib API. Ppxlib is responsible +for acknowledging the various rewriters an end user wants to use, making sure +they can be composed together and performing the actual rewriting of input +files. + +The hook in the compiler allows ppxlib to insert itself in the compilation +pipeline and perform the rewriting of input files based on a list of ppx +rewriters specified by the user. The hooks take the form of command line flags +that take a command to execute. The compiler supports two slightly different +flags, for providing commands that are executed at different stages: [-pp] and +[-ppx]. The difference between the two is as follow: + +- [-pp] takes as argument a command that is used to parse the textual + representation. Such a command can produce either a plain OCaml source file or + a serialised representation of the AST + +- [-ppx] takes as argument a command that is given a serialised representation + of the AST and produces another serialised AST + +Ppxlib generally uses the first one as it yields faster compilation times, +however it supports both methods of operation. + +{2 Is ppxlib necessary?} + +Yes. While authors of ppx rewriters may in theory use the compiler hooks +directly, doing so is strongly discouraged for the following reasons: + +- composing such ppx rewriters is slow and yields much slower compilation times +- the ABI of the hook is not stable and regularly changes in incompatible ways. + This means that a ppx rewriter using the compiler hook directly is likely to + work only with a single version of the OCaml compiler +- the compiler does not provide good composition semantics, which means that + input files will not always be transformed as expected. It is hard to predict + what the final result will be, and for end users it is hard to understand what + is happening when things go wrong +- the compiler doesn't handle hygiene: if an attribute is mistyped or misplaced, + it is silently ignored by the compiler. If two ppx rewriters want to interpret + the same attribute or extension point in incompatible ways, the result is not + specified + +In summary, ppxlib abstracts away the low-level details of the ppx +system and exposes a consistent model to authors of ppx rewriters and end users. + +{2 Current state of the ppx ecosystem} + +Ppxlib was developed after the introduction of the ppx system. As a result, many +ppx rewriters do not currently use ppxlib and are using the compiler hooks +directly. Ppxlib can acknowledge such rewriters so that they can be used in +conjunction with more modern rewriters, however it cannot provide a good +composition or hygiene story when using such ppx rewriters. + +{2 Note on stability regarding new compiler releases} + +Due to the nature of the ppx system, it is hard for ppxlib to provide full +protection against compiler changes. This means that a ppx rewriter written +against ppxlib today can be broken by a future release of the OCaml compiler and +a new release of the ppx rewriter will be necessary to support the new compiler. + +However the following is true: every time this might happen, it will be possible +to extend ppxlib to provide a greater protection, so that eventually the whole +ppx ecosystem is completely shielded from breaking compiler changes. + +{1:ppxlib-for-end-users PPX for end users} + +This section describes how to use ppx rewriters for end users. + +{2 Using a ppx rewriter in your project} + + +To use one or more ppx rewriters written by you or someone else, simply list +them in the [preprocess] field of your [dune] file. For instance: + +{[ + + (library + (name my_lib) + (preprocess (pps (ppx_sexp_conv ppx_expect)))) +]} + +Some ppx rewriters takes parameters in the form of command line flags. These can +be specified using the usual convention for command line flags: atoms starting +with [-] are treated as flags and [--] can be used to separate ppx rewriter +names from more command line flags. For instance: + +{[ + (library + (name my_lib) + (preprocess + (pps (ppx_sexp_conv ppx_expect -inline-test-drop)))) + + (library + (name my_lib) + (preprocess + (pps (ppx_sexp_conv ppx_expect -- --cookie "x=42")))) +]} + +Once this is done, you can use whatever feature is offered by the ppx rewriter. + +{2 Looking at the generated code} + +At the time of writing this manual, there is no easy way to look at the fully +transformed input file in order to see exactly what will be compiled by OCaml. +You can however use the following method, which is not great but works: run +[ocamlc -dsource _build/default/]. For +instance to see the transformed version of [src/foo.ml], run: + +{[ + $ ocamlc -dsource _build/default/src/foo.pp.ml +]} + +{2 [@@deriving_inline]} + +Ppxlib supports attaching the [[@@deriving]] attribute to type declaration. This +is used to generate code at compile time based on the structure of the type. For +this particular case, ppxlib supports an alternative way to look at the +generated code: replace [[@@deriving ]] by [[@@deriving_inline +][@@@end]]. Then run the following command: + +{[ + $ dune build --auto-promote +]} + +If you reload the file in your editor, you should now see the contents of the +generated code between the [[@@deriving_inline]] and [[@@@end]] attribute. This +can help understanding what is provided by a ppx rewriter or debug compilation +errors. + +{2 Dropping ppx dependencies with [@@deriving_inline]} + +You might notice that the resulting file when using [[@@deriving_inline]] needs +no special treatment to be compiled. In particular, you can build it without the +ppx rewriter or even ppxlib. You only need them while developing the project, in +order to automatically produce the generated code but that's it. End users of +your project do not need to install ppxlib and other ppx rewriters themselves. + +{{:https://dune.build/}Dune} gracefully supports this workflow: simply replace +[preprocess] in your [dune] file by [lint]. For instance: + +{[ + (library + (name my_lib) + (lint (pps (ppx_sexp_conv)))) +]} + +Then to regenerate the parts between [[@@deriving_inline]] and [[@@@end]], run +the following command: + +{[ + $ dune build @lint --auto-promote +]} + +{1:ppxlib-for-plugin-authors PPX for plugin authors} + +This section describes how to use [ppxlib] for PPX plugin authors. + +{2 Getting started} + +There are two main kinds of PPX plugins you can write with [ppxlib]: + +- Extension rewriters i.e. ppx plugins that rewrite extension points such as + [[%my_ext ...]] into valid OCaml code. +- Derivers i.e. ppx plugins that generate code from type, module or exception + declarations annotated with [[@@deriving my_deriver]]. + +It is also possible to write more advanced transformations such as rewriting +constants that bear the right suffix, rewriting function calls based on the +function identifier or to generate code from items annotated with a custom +attribute but we won't cover those in this section. + +[ppxlib] compiles those transformations into rules which allows it to apply them +to the right AST nodes, even recursively in nodes generated by other +transformations, in a single AST traversal. + +Note that you can also write arbitrary, whole AST transformations with ppxlib +but they don't have a clear composition semantic since they have to be applied +sequentially as opposed to the other, better defined rewriting rule. You should +always prefer the above mentioned transformations instead when possible. + +{3 The OCaml AST} + +As described in {!page-"ppx-overview"}, PPX rewriters don't operate at the text +level but instead used the compiler's internal representation of the source +code: the Abstract Syntax Tree or AST. + +A lot of the following sections of the manual assume a certain level of +familiarity with the OCaml AST so we'll try to cover the basics here and to give +you some pointers to deepen your knowledge on the subject. + +The types describing the AST are defined in the [Parsetree] module of OCaml's +compiler-libs. Note that they vary from one version of the compiler to another +so make sure you look at an up to date version and most importantly to the one +corresponding to what ppxlib's using internally. You can find the module's API +documentation online +{{:https://caml.inria.fr/pub/docs/manual-ocaml/compilerlibref/Parsetree.html}here}. +If you're new to these parts of OCaml it's not always easy to navigate as it +just contains the raw type declarations but no actual documentation. This +documentation is actually written in [parsetree.mli] but not in a way that +allows it to make its way to the online doc unfortunately. Until this is fixed +in the compiler you can look at the local copy in one of your opam switches: +[/lib/ocaml/compiler-libs/parsetree.mli]. Here you'll find +detailed explanations as to which part of the concrete syntax the various types +correspond to. + +Ppxlib includes a [Parsetree] module for every version of OCaml since [4.02]. +For instance, the version for [4.05] is in {!Astlib.Ast_405.Parsetree}. In what +comes next, we will link the values we describe to the {!Ppxlib.Parsetree} +module, which corresponds to one version of [Parsetree]. + +[Parsetree] is quite a large module and there are plenty of types there, a lot +of which you don't necessarily have to know when writing a rewriter. The two +main entry points are the [structure] and [signature] types which, amongst other +things, describe respectively the content of [.ml] and [.mli] files. Other types +you should be familiar with are: + +- {{!Ppxlib.Parsetree.expression}[expression]} which describes anything in OCaml + that evaluates to a value, the right hand side of a let binding or the + branches of an if-then-else for instance. - + {{!Ppxlib.Parsetree.pattern}[pattern]} which is what you use to deconstruct an + OCaml value, the left hand side of a let binding or a pattern-matching case + for example. - {{!Ppxlib.Parsetree.core_type}[core_type]} which describes type + expressions ie what you use to explicitly constrain the type of an expression + or describe the type of a value in your [.mli] files. Usually it's what comes + after a [:]. - {{!Ppxlib.Parsetree.structure_item}[structure_item]} and + {{!Ppxlib.Parsetree.signature_item}[signature_item]} which describe the top + level AST nodes you can find in a structure or signature such as type + definitions, value declarations or module declarations. + +Knowing what these types correspond to puts you in a good position to write a +PPX plugin as they are the parts of the AST you will deal with the most in +general. + +{3 Writing an extension rewriter} + +To write your ppx plugin you'll need to add the following stanza in your dune +file: + +{[ + (library + (public_name my_ppx_rewriter) + (kind ppx_rewriter) + (libraries ppxlib)) +]} + +You'll note that you have to let dune know this is not a regular library but a +ppx_rewriter using the [kind] field. The public name you chose here is the name +your users will refer to your ppx in there [preprocess] field. E.g. here to use +this ppx rewriter one would add the [(preprocess (pps my_ppx_rewriter))] to +their [library] or [executable] stanza. + +You will also need the following [my_ppx_rewriter.ml]: + +{[ + open Ppxlib + + let expand ~ctxt payload = + ... + + let my_extension = + Extension.V3.declare + "my_ext" + + + expand + + let rule = Ppxlib.Context_free.Rule.extension my_extension + + let () = + Driver.register_transformation + ~rules:[rule] + "my_ext" +]} + +There are a few things to explain here. The last part, i.e. the call to +{{!Ppxlib.Driver.register_transformation}[Driver.register_transformation]} is +common to almost all ppxlib-based PPX plugins and is how you let [ppxlib] know +about your transformation. You'll note that here we register a single rule but +it is possible to register several rules for a single logical transformation. + +The above is specific to extension rewriters. You need to declare a ppxlib +{{!Ppxlib.Extension}[Extension]}. The first argument is the extension name, +that's what will appear after the [%] in the extension point when using your +rewriter, e.g. here this will transform [[%my_ext ...]] nodes. The +[] argument describes where in OCaml code your this extension +can be used. You can find the full list in the API documentation in the +{{!Ppxlib.Extension.Context}[Extension.Context]} module. The [] +argument helps you restrict what users can put into the payload of your +extension, i.e. [[%my_ext ]]. We cover +{{!Ppxlib.Ast_pattern}[Ast_pattern]} in depths here but the simplest form it can +take is {{!Ppxlib.Ast_pattern.__}[Ast_pattern.__]} which allows any payload +allowed by the language and passes it to the expand function which is the last +argument here. The expand function is where the logic for your transformation is +implemented. It receives an +{{!Ppxlib.Expansion_context.Extension.t}[Expansion_context.Extension.t]} +argument labelled [ctxt] and other arguments whose type and number depends on +the [] argument. The return type of the function is determined by +the [] argument, e.g. in the following example: + +{[ + Extension.V3.declare "my_ext" Extension.Context.expression Ast_pattern.__ expand +]} + +The type of the [expand] function is: + +{[ + val expand : ctxt: Expansion_context.Extension.t -> payload -> expression +]} + +If you want to look at a concrete example of extension rewriter you can find one +in the [examples/] folder of the [ppxlib] repository +{{:https://github.com/ocaml-ppx/ppxlib/tree/main/examples/simple-extension-rewriter}here}. + +{3 Writing a deriver} + +Similarly to extension rewriters, derivers must be declared as such to dune. To +do so you can use the following stanza in your dune file: + +{[ + (library + (public_name my_ppx_deriver) + (kind ppx_deriver) + (libraries ppxlib)) +]} + +Same as above, the public name used here determines how users will refer to your +ppx deriver in their dune stanzas. + +You will also need the following [my_ppx_deriver.ml]: + +{[ + open Ppxlib + + let generate_impl ~ctxt (rec_flag, type_declarations) = + ... + + let generate_intf ~ctxt (rec_flag, type_declarations) = + ... + + let impl_generator = Deriving.Generator.V2.make_noarg generate_impl + + let intf_generator = Deriving.Generator.V2.make_noarg generate_intf + + let my_deriver = + Deriving.add + "my_deriver" + ~str_type_decl:impl_generator + ~sig_type_decl:intf_generator +]} + +The call to {{!Ppxlib.Deriving.add}[Deriving.add]} is how you'll let [ppxlib] +know about your deriver. The first string argument is the name of the deriver as +referred to by your users, in the above example one would add a [[@@deriving +my_deriver]] annotation to use this plugin. Here our deriver can be used on type +declarations, be it in structures or signatures (i.e. implementation or +interfaces, [.ml] or [.mli]). + +To add a deriver you first have to define a generator. You need one for each +node you want to derive code from. Here we just need one for type declarations +in structures and one for type declarations in signatures. To do that you need +the +{{!Ppxlib.Deriving.Generator.V2.make_noarg}[Deriving.Generator.V2.make_noarg]} +constructor. You'll note that there exists +{{!Ppxlib.Deriving.Generator.V2.make}[Deriving.Generator.V2.make]} variant if +you wish to allow passing arguments to your deriver but to keep this tutorial +simple we won't cover this here. The only mandatory argument to the constructor +is a function which takes a labelled +{{!Ppxlib.Expansion_context.Deriving.t}[Expansion_context.Deriving.t]}, an +['input_ast] and returns an ['output_ast] and that will give us a [('output_ast, +'input_ast) Deriving.Generator.t]. Much like the [expand] function described in +the section about extension rewriters, this function is where the actual +implementation for your deriver lives. The [str_type_decl] argument of +{{!Ppxlib.Deriving.add}[Deriving.add]} expects a [(structure, rec_flag * +type_declaration list) Generator.t] so our [generate_impl] function must take a +pair [(rec_flag, type_declaration list)] and return a [structure] i.e. a +[structure_item list], for instance a list of function or module declaration. +The same goes for the [generate_intf] function except that it must return a +[signature]. It is often the case that a deriver has a generator for both the +structure and signature variants of a node. That allows users to generate the +signature corresponding to the code generated by the deriver in their [.ml] +files instead of having to type it and maintain it themselves. + +If you want to look at a concrete example of deriver you can find one in the +[examples/] folder of the [ppxlib] repository +{{:https://github.com/ocaml-ppx/ppxlib/tree/main/examples/simple-deriver}here}. + +{2 Metaquot} + +[metaquot] is a PPX plugin that helps you write PPX plugins. It lets you write +AST node values using the actual corresponding OCaml syntax instead of building +them with the more verbose AST types or [Ast_builder]. + +To use [metaquot] you need to add it to the list of preprocessor for your PPX +plugin: + +{[ + (library + (name my_plugin_lib) + (preprocess (pps ppxlib.metaquot))) +]} + +[metaquot] can be used both to write expressions of some of the AST types or to +write patterns to match over those same types. The various extensions it exposes +can be used in both contexts, expressions or patterns. + +The extension you should use depends on the type of AST node you're trying to +write or to pattern-match over. You can use the following extensions with the +following syntax: + +- [expr] for {{!Ppxlib.Parsetree.expression}[Parsetree.expression]}: + [[%expr 1 + 1]] +- [pat] for {{!Ppxlib.Parsetree.pattern}[Parsetree.pattern]}: [[%pat? ("", _)]] +- [type] for {{!Ppxlib.Parsetree.core_type}[Parsetree.core_type]}: + [[%type: int -> string]] +- [stri] for {{!Ppxlib.Parsetree.structure_item}[Parsetree.structure_item]}: + [[%stri let a = 1]] +- [sigi] for {{!Ppxlib.Parsetree.signature_item}[Parsetree.signature_item]}: + [[%sigi: val i : int]] +- [str] and [sig] respectively for + {{!Ppxlib.Parsetree.structure}[Parsetree.structure]} + and {{!Ppxlib.Parsetree.signature}[Parsetree.signature]}. They use similar + syntax to the [_item] extensions above as they are just a list of such items. + +If you consider the first example [[%expr 1 + 1]], in an expression context, +[metaquot] will actually expand it into: + +{[ + { + pexp_desc = + (Pexp_apply + ({ + pexp_desc = (Pexp_ident { txt = (Lident "+"); loc }); + pexp_loc = loc; + pexp_attributes = [] + }, + [(Nolabel, + { + pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); + pexp_loc = loc; + pexp_attributes = [] + }); + (Nolabel, + { + pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); + pexp_loc = loc; + pexp_attributes = [] + })])); + pexp_loc = loc; + pexp_attributes = [] + } +]} + +For this to compile you need the AST types to be in the scope so you should +always use [metaquot] where [Ppxlib] is opened. You'll also note that the +generated node expects a [loc : Location.t] value to be available. The produced +AST node value and every other nodes within it will be located to [loc]. You +should make sure [loc] is the location you want for your generated code when +using [metaquot]. + +When using the pattern extension, it will produce a pattern that matches no +matter what the location and attributes are. For the previous example for +instance, it will produce the following pattern: + +{[ + { + pexp_desc = + (Pexp_apply + ({ + pexp_desc = (Pexp_ident { txt = (Lident "+"); loc = _ }); + pexp_loc = _; + pexp_attributes = _ + }, + [(Nolabel, + { + pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); + pexp_loc = _; + pexp_attributes = _ + }); + (Nolabel, + { + pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); + pexp_loc = _; + pexp_attributes = _ + })])); + pexp_loc = _; + pexp_attributes = _ + } +]} + +Using these extensions alone, you can only produce constant/static AST nodes. +You can't bind variables in the generated patterns either. [metaquot] has a +solution for that as well: anti-quotation. You can use anti-quotation to insert +any expression or pattern representing an AST node. That way you can include +dynamically generated nodes inside a [metaquot] expression extension point or +use a wildcard or variable pattern in a pattern extension. + +Consider the following example: + +{[ + let with_suffix_expr ~loc s = + let dynamic_node = Ast_builder.Default.estring ~loc s in + [%expr [%e dynamic_node] ^ "some_fixed_suffix"] +]} + +The [with_suffix_expr] function will create an [expression] which is the +concatenation of the [s] argument and the fixed suffix. I.e. [with_suffix_expr +"some_dynamic_stem"] is equivalent to [[%expr "some_dynamic_steme" ^ +"some_fixed_suffix"]]. + +Similarly if you want to ignore some parts of AST nodes and extract some others +when pattern-matching over them, you can use anti-quotation: + +{[ + match some_expr_node with + | [%expr 1 + [%e? _] + [%e? third]] -> do_something_with third +]} + +The syntax for anti-quotation depends on the type of the node you wish to insert: + +- [e] to anti-quote values of type + {{!Ppxlib.Parsetree.expression}[Parsetree.expression]}: + [[%expr 1 + [%e some_expr_node]]] +- [p] to anti-quote values of type + {{!Ppxlib.Parsetree.pattern}[Parsetree.pattern]}: + [[%pat? (1, [%p some_pat_node])]] +- [t] to anti-quote values of type + {{!Ppxlib.Parsetree.core_type}[Parsetree.core_type]}: + [[%type: int -> [%t some_core_type_node]]] +- [m] to anti-quote values of type + {{!Ppxlib.Parsetree.module_expr}[Parsetree.module_expr]} + or {{!Ppxlib.Parsetree.module_type}[module_type]}: + [[%expr let module M = [%m some_module_expr_node]]] or + [[%sigi: module M : [%m some_module_type_node]]] +- [i] to anti-quote values of type + {{!Ppxlib.Parsetree.structure_item}[Parsetree.structure_item]} or + {{!Ppxlib.Parsetree.signature_item}[signature_item]}: + [[%str let a = 1 [%%i some_structure_item_node]]] or + [[%sig: val a : int [%%i some_signature_item_node]]] + +Note that when anti-quoting in a pattern context you must always use the [?] in +the anti-quotation extension as its payload should always be a pattern the same +way it must always be an expression in an expression context. + +As you may have noticed, you can anti-quote expressions which type differs from +the type of the whole [metaquot] extension point. E.g. you can write: + +{[ + let structure_item = + [%stri let [%p some_pat] : [%t some_type] = [%e some_expr]] +]} + +{2 Handling errors} + + +In order to give a nice user experience when reporting errors or failures in a ppx, it is necessary to include as much of the generated content as possible. Most IDE tools, such as Merlin, rely on the AST for their features, such as displaying type, jumping to definition or showing the list of errors. + +{3 Embedding the errors in the AST} + +A common way to report an error is to throw an exception. However, this method interrupts the execution flow of the ppxlib driver and leaves later PPX's unexpanded when handing the AST over to merlin. + +Instead, it is better to always return a valid AST, as complete as possible, but with "error extension nodes" at every place where successful code generation was impossible. Error extension nodes are special extension nodes [[%ocaml.error error_message]], which can be embedded into a valid AST and are interpreted later as errors, for instance by the compiler or Merlin. As all extension nodes, they can be put {{:https://ocaml.org/manual/extensionnodes.html}at many places in the AST}, to replace for instance structure items, expressions or patterns. + +So whenever you're in doubt if to throw an exception or if to embed the error as an error extension node when writing a ppx rewriter, the answer is most likely: embed the error is the way to go! And whenever you're in doubt about where exactly inside the AST to embed the error, a good rule of thumb is: as deep in the AST as possible. + +For instance, suppose a rewriter is supposed to define a new record type, but there is an error in the generation of the type of one field. In order to have the most complete AST as output, the rewriter can still define the type and all of its fields, putting an extension node in place of the type of the faulty field: + +{[ + type long_record = { + field_1: int; + field_2: [%ocaml.error "field_2 could not be implemented due to foo"]; + } +]} + +Ppxlib provides a function in its API to create error extension nodes: {{!Ppxlib.Location.error_extensionf}[error_extensionf]}. This function creates an extension node, which has then to be transformed in the right kind of node using functions such as for instance {{!Ppxlib.Ast_builder.Default.pexp_extension}[pexp_extension]}. + +{3 A documented example} + +Let us give an example. We will define a deriver on types records, which constructs a default value from a given type. For instance, the derivation on the type [type t = { x:int; y: float; z: string}] would yield [let default_t = {x= 0; y= 0.; z= ""}]. This deriver has two limitations: + +{ol +{- It does not work on other types than records,} +{- It only works for records containing fields of type [string], [int] or [float].} +} + +The rewriter should warn the user about these limitations with a good error reporting. Let us first look at the second point. Here is the function mapping the fields from the type definition to a default expression. + +{[ + let create_record ~loc fields = + let declaration_to_instantiation (ld : label_declaration) = + let loc = ld.pld_loc in + let { pld_type; pld_name; _ } = ld in + let e = + match pld_type with + | { ptyp_desc = Ptyp_constr ({ txt = Lident "string"; _ }, []); _ } -> + pexp_constant ~loc (Pconst_string ("", loc, None)) + | { ptyp_desc = Ptyp_constr ({ txt = Lident "int"; _ }, []); _ } -> + pexp_constant ~loc (Pconst_integer ("0", None)) + | { ptyp_desc = Ptyp_constr ({ txt = Lident "float"; _ }, []); _ } -> + pexp_constant ~loc (Pconst_float ("0.", None)) + | _ -> + pexp_extension ~loc + @@ Location.error_extensionf ~loc + "Default value can only be derived for int, float, and string." + in + ({ txt = Lident pld_name.txt; loc }, e) + in + let l = List.map fields ~f:declaration_to_instantiation in + pexp_record ~loc l None +]} + + +When the record definition contains several fields with types other than [int], [float] or [string], several error nodes are added in the AST. Moreover, the location of the error nodes corresponds to the definition of the record fields. This allows tools such as Merlin to report all errors at once, at the right location, resulting in a better workflow than having to recompile everytime one error is corrected to see the next one. + +The first limitation is that the deriver cannot work on non record types. However, we decided here to derive a default value even in the case of non-record types, so that it does not appear as undefined in the remaining of the file. This impossible value consists of an error extension node. + +{[ + let generate_impl ~ctxt (_rec_flag, type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + List.map type_declarations ~f:(fun (td : type_declaration) -> + let e, name = + match td with + | { ptype_kind = Ptype_record fields; ptype_name; ptype_loc; _ } -> + (create_record ~loc:ptype_loc fields, ptype_name) + | { ptype_name; ptype_loc; _ } -> + ( pexp_extension ~loc + @@ Location.error_extensionf ~loc:ptype_loc + "Cannot derive accessors for non record type %s" + ptype_name.txt, + ptype_name ) + in + [ + pstr_value ~loc Nonrecursive + [ + { + pvb_pat = ppat_var ~loc { txt = "default_" ^ name.txt; loc }; + pvb_expr = e; + pvb_attributes = []; + pvb_loc = loc; + }; + ]; + ]) + |> List.concat +]} + +{3 In case of panic} + +In some rare cases, it might happen that a whole file rewriter is not able to output a meaningful AST. In this case, they might be tempted to raise a located error: an exception that includes the location of the error. Moreover, this h as historically been what was suggested to do by ppxlib examples, but is now discouraged in most of the cases, as it prevents Merlin features to work well. + +If such an exception is uncaught, the ppx driver will return with an error code and the exception will be pretty-printed, including the location (that's the case when the driver is called by dune). When the driver is spawned with the [-embed-errors] or [-as-ppx] flags (that's the case when the driver is called by merlin), the driver will look for located error. If it catches one, it will stop its chain of rewriting at this point, and output an AST consisting of the located error followed by the last valid AST: the one passed to the raising rewriter. + +Even more in context-free rewriters, raising should be avoided, in favour of outputting a single error node when a finer grained reporting is not needed or possible. As the whole context-free rewriting is done in one traverse of the AST, a single raise will cancel both the context-free pass and upcoming rewriters, and the AST prior to the context-free pass will be outputted together with the error. + +The function provided by the API to raise located errors is {{!Ppxlib.Location.raise_errorf}[raise_errorf]}. + +{3 Migrating from raising to embedding errors} + +Lots of ppx-es exclusively use {{!Ppxlib.Location.raise_errorf}[raise_errorf]} to report errors, instead of the more merlin friendly way consisting of embedding errors in the AST, as described in this section. + +If you want to migrate such a codebase to the embedding approach, here are a few recipes to do that. Indeed, it might not be completely trivial, as raising can be done anywhere in the code, including in places where "embedding" would not make sense. What you can do is to turn your internal raising functions to function returning a [result] type. + +The workflow for this change would look like this: + +{ol +{- Search through your code all uses of {{!Ppxlib.Location.raise_errorf}[raise_errorf]}, using for instance [grep].} +{- For each of them, turn them into function returning a [(_, extension) result] type, using {{!Ppxlib.Location.error_extensionf}[error_extensionf]} to generate the [Error].} +{- Let the compiler or merlin tell you where you need to propagate the [result] type (most certainly using [map]s and [bind]s).} +{- When you have propagated until a point where you can, embed the extension in case of [Error extension].} +} + +This is quite convenient, as it allows you to do a "type-driven" modification, using at full the static analysis of OCaml to never omit a special case, and to confidently find the place the most deeply in the AST to embed the error. However, it might induces quite a lot of code modification, and exceptions are sometimes convenient to use, depending on the taste. In case you want to do only a very simple to keep using exception, catch them and turn them into extension points embedded in the AST, here is an example: + +{[ +let rewrite_extension_point loc payload = + try generate_ast payload + with exn -> + let get_error exn = + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> error + in + let extension = exn |> get_error |> Location.Error.to_extension in + Ast_builder.Default.pstr_extension ~loc ext [] +]} diff -Nru ppxlib-0.24.0/doc/ppx-for-end-users.rst ppxlib-0.27.0/doc/ppx-for-end-users.rst --- ppxlib-0.24.0/doc/ppx-for-end-users.rst 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/doc/ppx-for-end-users.rst 1970-01-01 00:00:00.000000000 +0000 @@ -1,101 +0,0 @@ -***************** -PPX for end users -***************** - -This section describes how to use ppx rewriters for end users. - -Using a ppx rewriter in your project ------------------------------------- - -To use one or more ppx rewriters written by you or someone else, -simply list them in the ``preprocess`` field of your ``dune`` file. For -instance: - -.. code:: scheme - - (library - (name my_lib) - (preprocess (pps (ppx_sexp_conv ppx_expect)))) - -Some ppx rewriters takes parameters in the form of command line -flags. These can be specified using the usual convention for command -line flags: atoms starting with ``-`` are treated as flags and ``--`` -can be used to separate ppx rewriter names from more command line -flags. For instance: - -.. code:: scheme - - (library - (name my_lib) - (preprocess - (pps (ppx_sexp_conv ppx_expect -inline-test-drop)))) - - (library - (name my_lib) - (preprocess - (pps (ppx_sexp_conv ppx_expect -- --cookie "x=42")))) - -Once this is done, you can use whatever feature is offered by the ppx -rewriter. - -Looking at the generated code ------------------------------ - -At the time of writing this manual, there is no easy way to look at -the fully transformed input file in order to see exactly what will be -compiled by OCaml. You can however use the following method, which is -not great but works: run ``ocamlc -dsource -_build/default/``. For instance to -see the transformed version of ``src/foo.ml``, run: - -.. code:: sh - - $ ocamlc -dsource _build/default/src/foo.pp.ml - -[@@deriving_inline] -------------------- - -Ppxlib supports attaching the ``[@@deriving]`` attribute to type -declaration. This is used to generate code at compile time based on -the structure of the type. For this particular case, ppxlib supports -an alternative way to look at the generated code: replace -``[@@deriving ]`` by ``[@@deriving_inline -][@@@end]``. Then run the following command: - -.. code:: sh - - $ dune build --auto-promote - -If you reload the file in your editor, you should now see the contents -of the generated code between the ``[@@deriving_inline]`` and -``[@@@end]`` attribute. This can help understanding what is provided -by a ppx rewriter or debug compilation errors. - -Dropping ppx dependencies with [@@deriving_inline] --------------------------------------------------- - -You might notice that the resulting file when using -``[@@deriving_inline]`` needs no special treatment to be compiled. In -particular, you can build it without the ppx rewriter or even -ppxlib. You only need them while developing the project, in order to -automatically produce the generated code but that's it. End users of -your project do not need to install ppxlib and other ppx rewriters -themselves. - -Dune_ gracefully supports this workflow: simply replace ``preprocess`` -in your ``dune`` file by ``lint``. For instance: - -.. code:: scheme - - (library - (name my_lib) - (lint (pps (ppx_sexp_conv)))) - -Then to regenerate the parts between ``[@@deriving_inline]`` and -``[@@@end]``, run the following command: - -.. code:: sh - - $ dune build @lint --auto-promote - -.. _Dune: https://dune.build/ diff -Nru ppxlib-0.24.0/doc/ppx-for-plugin-authors.rst ppxlib-0.27.0/doc/ppx-for-plugin-authors.rst --- ppxlib-0.24.0/doc/ppx-for-plugin-authors.rst 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/doc/ppx-for-plugin-authors.rst 1970-01-01 00:00:00.000000000 +0000 @@ -1,361 +0,0 @@ -********************** -PPX for plugin authors -********************** - -This section describes how to use ``ppxlib`` for PPX plugin authors. - -Getting started ---------------- - -There are two main kinds of PPX plugins you can write with ``ppxlib``: - -- Extension rewriters i.e. ppx plugins that rewrite extension points such as ``[%my_ext ...]`` - into valid OCaml code. -- Derivers i.e. ppx plugins that generate code from type, module or exception declarations - annotated with ``[@@deriving my_deriver]``. - -It is also possible to write more advanced transformations such as rewriting constants that bear the -right suffix, rewriting function calls based on the function identifier or to generate code from -items annotated with a custom attribute but we won't cover those in this section. - -``ppxlib`` compiles those transformations into rules which allows it to apply them to the right AST -nodes, even recursively in nodes generated by other transformations, in a single AST traversal. - -Note that you can also write arbitrary, whole AST transformations with ppxlib but they don't have a -clear composition semantic since they have to be applied sequentially as opposed to the -other, better defined rewriting rule. You should always prefer the above mentioned transformations -instead when possible. - -The OCaml AST -^^^^^^^^^^^^^ - -As described in :ref:`ppx-overview`, PPX rewriters don't operate at the text level but instead used -the compiler's internal representation of the source code: the Abstract Syntax Tree or AST. - -A lot of the following sections of the manual assume a certain level of familiarity with the OCaml -AST so we'll try to cover the basics here and to give you some pointers to deepen your knowledge on -the subject. - -The types describing the AST are defined in the ``Parsetree`` module of OCaml's compiler-libs. Note -that they vary from one version of the compiler to another so make sure you look at an up to date -version and most importantly to the one corresponding to what ppxlib's using internally. -You can find the module's API documentation online -`here `_. If you're new -to these parts of OCaml it's not always easy to navigate as it just contains the raw type -declarations but no actual documentation. -This documentation is actually written in ``parsetree.mli`` but not in a way that allows it to make -its way to the online doc unfortunately. Until this is fixed in the compiler you can look at the -local copy in one of your opam switches: -``/lib/ocaml/compiler-libs/parsetree.mli``. Here you'll find detailed -explanations as to which part of the concrete syntax the various types correspond to. - -``Parsetree`` is quite a large module and there are plenty of types there, a lot of which you don't -necessarily have to know when writing a rewriter. The two main entry points are the ``structure`` -and ``signature`` types which, amongst other things, describe respectively the content of ``.ml`` -and ``.mli`` files. -Other types you should be familiar with are: - -* ``expression`` which describes anything in OCaml that evaluates to a value, the right hand side - of a let binding or the branches of an if-then-else for instance. -* ``pattern`` which is what you use to deconstruct an OCaml value, the left hand side of a let - binding or a pattern-matching case for example. -* ``core_type`` which describes type expressions ie what you use to explicitly constrain the type - of an expression or describe the type of a value in your ``.mli`` files. Usually it's what comes - after a ``:``. -* ``structure_item`` and ``signature_item`` which describe the top level AST nodes you can find in a - structure or signature such as type definitions, value declarations or module declarations. - -Knowing what these types correspond to puts you in a good position to write a PPX plugin as they are -the parts of the AST you will deal with the most in general. - -Writing an extension rewriter -^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -To write your ppx plugin you'll need to add the following stanza in your dune file: - -.. code:: scheme - - (library - (public_name my_ppx_rewriter) - (kind ppx_rewriter) - (libraries ppxlib)) - -You'll note that you have to let dune know this is not a regular library but a ppx_rewriter using -the ``kind`` field. -The public name you chose here is the name your users will refer to your ppx in there ``preprocess`` -field. E.g. here to use this ppx rewriter one would add the ``(preprocess (pps my_ppx_rewriter))`` -to their ``library`` or ``executable`` stanza. - -You will also need the following ``my_ppx_rewriter.ml``: - -.. code:: ocaml - - open Ppxlib - - let expand ~ctxt payload = - ... - - let my_extension = - Extension.V3.declare - "my_ext" - - - expand - - let rule = Ppxlib.Context_free.Rule.extension my_extension - - let () = - Driver.register_transformation - ~rules:[rule] - "my_ext" - -There are a few things to explain here. The last part, i.e. the call to -``Driver.register_transformation`` is common to almost all ppxlib-based PPX plugins and is how -you let ``ppxlib`` know about your transformation. You'll note that here we register a single rule -but it is possible to register several rules for a single logical transformation. - -The above is specific to extension rewriters. You need to declare a ppxlib ``Extension``. -The first argument is the extension name, that's what will appear after the ``%`` in the extension -point when using your rewriter, e.g. here this will transform ``[%my_ext ...]`` nodes. -The ```` argument describes where in OCaml code your this extension can be used. -You can find the full list in the API documentation for ``Extension.Context`` -`here `_. -The ```` argument helps you restrict what users can put into the payload of your -extension, i.e. ``[%my_ext ]``. We cover ``Ast_pattern`` in depths here but the -simplest form it can take is ``Ast_pattern.__`` which allows any payload allowed by the language -and passes it to the expand function which is the last argument here. -The expand function is where the logic for your transformation is implemented. It receives an -``Expansion_context.Extension.t`` argument labelled ``ctxt`` and other arguments whose type and -number depends on the ```` argument. The return type of the function is determined -by the ```` argument, e.g. in the following example: - -.. code:: ocaml - - Extension.V3.declare "my_ext" Extension.Context.expression Ast_pattern.__ expand - -The type of the ``expand`` function is: - -.. code:: ocaml - - val expand : ctxt: Expansion_context.Extension.t -> payload -> expression - - -If you want to look at a concrete example of extension rewriter you can find one in the -``examples/`` folder of the ``ppxlib`` repository -`here `_. - -Writing a deriver -^^^^^^^^^^^^^^^^^ - -Similarly to extension rewriters, derivers must be declared as such to dune. To do so you can use -the following stanza in your dune file: - -.. code:: scheme - - (library - (public_name my_ppx_deriver) - (kind ppx_deriver) - (libraries ppxlib)) - -Same as above, the public name used here determines how users will refer to your ppx deriver in -their dune stanzas. - -You will also need the following ``my_ppx_deriver.ml``: - -.. code:: ocaml - - open Ppxlib - - let generate_impl ~ctxt (rec_flag, type_declarations) = - ... - - let generate_intf ~ctxt (rec_flag, type_declarations) = - ... - - let impl_generator = Deriving.Generator.V2.make_noarg generate_impl - - let intf_generator = Deriving.Generator.V2.make_noarg generate_intf - - let my_deriver = - Deriving.add - "my_deriver" - ~str_type_decl:impl_generator - ~sig_type_decl:intf_generator - - -The call to ``Deriving.add`` is how you'll let ``ppxlib`` know about your deriver. The first string -argument is the name of the deriver as referred to by your users, in the above example one would add -a ``[@@deriving my_deriver]`` annotation to use this plugin. -Here our deriver can be used on type declarations, be it in structures or signatures (i.e. -implementation or interfaces, ``.ml`` or ``.mli``). - -To add a deriver you first have to define a generator. You need one for each node you want to derive -code from. Here we just need one for type declarations in structures and one for type declarations in -signatures. To do that you need the ``Deriving.Generator.V2.make_noarg`` constructor. You'll note -that there exists ``Deriving.Generator.V2.make`` variant if you wish to allow passing arguments to -your deriver but to keep this tutorial simple we won't cover this here. -The only mandatory argument to the constructor is a function which takes a labelled -``Expansion_context.Deriving.t``, an ``'input_ast`` and returns an ``'output_ast`` and that will -give us a ``('output_ast, 'input_ast) Deriving.Generator.t``. Much like the ``expand`` function -described in the section about extension rewriters, this function is where the actual implementation -for your deriver lives. -The ``str_type_decl`` argument of ``Deriving.add`` expects a -``(structure, rec_flag * type_declaration list) Generator.t`` so our ``generate_impl`` function -must take a pair ``(rec_flag, type_declaration list)`` and return a ``structure`` i.e. a -``structure_item list``, for instance a list of function or module declaration. -The same goes for the ``generate_intf`` function except that it must return a ``signature``. -It is often the case that a deriver has a generator for both the structure and signature variants -of a node. That allows users to generate the signature corresponding to the code generated by the -deriver in their ``.ml`` files instead of having to type it and maintain it themselves. - -If you want to look at a concrete example of deriver you can find one in the -``examples/`` folder of the ``ppxlib`` repository -`here `_. - -Metaquot --------- - -``metaquot`` is a PPX plugin that helps you write PPX plugins. It lets you write AST node values -using the actual corresponding OCaml syntax instead of building them with the more verbose AST types -or ``Ast_builder``. - -To use ``metaquot`` you need to add it to the list of preprocessor for your PPX plugin: - -.. code:: scheme - - (library - (name my_plugin_lib) - (preprocess (pps ppxlib.metaquot))) - -``metaquot`` can be used both to write expressions of some of the AST types or to write patterns to -match over those same types. The various extensions it exposes can be used in both contexts, -expressions or patterns. - -The extension you should use depends on the type of AST node you're trying to write or to -pattern-match over. You can use the following extensions with the following syntax: - -- ``expr`` for ``Parsetree.expression``: ``[%expr 1 + 1]`` -- ``pat`` for ``Parsetree.pattern``: ``[%pat? ("", _)]`` -- ``type`` for ``Parsetree.core_type``: ``[%type: int -> string]`` -- ``stri`` for ``Parsetree.structure_item``: ``[%stri let a = 1]`` -- ``sigi`` for ``Parsetree.signature_item``: ``[%sigi: val i : int]`` -- ``str`` and ``sig`` respectively for ``Parsetree.structure`` and ``Parsetree.signature``. They use - similar syntax to the ``_item`` extensions above as they are just a list of such items. - -If you consider the first example ``[%expr 1 + 1]``, in an expression context, ``metaquot`` will -actually expand it into: - -.. code:: ocaml - - { - pexp_desc = - (Pexp_apply - ({ - pexp_desc = (Pexp_ident { txt = (Lident "+"); loc }); - pexp_loc = loc; - pexp_attributes = [] - }, - [(Nolabel, - { - pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); - pexp_loc = loc; - pexp_attributes = [] - }); - (Nolabel, - { - pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); - pexp_loc = loc; - pexp_attributes = [] - })])); - pexp_loc = loc; - pexp_attributes = [] - } - -For this to compile you need the AST types to be in the scope so you should always use ``metaquot`` -where ``Ppxlib`` is opened. -You'll also note that the generated node expects a ``loc : Location.t`` value to be available. The -produced AST node value and every other nodes within it will be located to ``loc``. You should make -sure ``loc`` is the location you want for your generated code when using ``metaquot``. - -When using the pattern extension, it will produce a pattern that matches no matter what the -location and attributes are. For the previous example for instance, it will produce the following -pattern: - -.. code:: ocaml - - { - pexp_desc = - (Pexp_apply - ({ - pexp_desc = (Pexp_ident { txt = (Lident "+"); loc = _ }); - pexp_loc = _; - pexp_attributes = _ - }, - [(Nolabel, - { - pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); - pexp_loc = _; - pexp_attributes = _ - }); - (Nolabel, - { - pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); - pexp_loc = _; - pexp_attributes = _ - })])); - pexp_loc = _; - pexp_attributes = _ - } - -Using these extensions alone, you can only produce constant/static AST nodes. You can't bind -variables in the generated patterns either. -``metaquot`` has a solution for that as well: anti-quotation. -You can use anti-quotation to insert any expression or pattern representing an AST node. -That way you can include dynamically generated nodes inside a ``metaquot`` expression extension point -or use a wildcard or variable pattern in a pattern extension. - -Consider the following example: - -.. code:: ocaml - - let with_suffix_expr ~loc s = - let dynamic_node = Ast_builder.Default.estring ~loc s in - [%expr [%e dynamic_node] ^ "some_fixed_suffix"] - -The ``with_suffix_expr`` function will create an ``expression`` which is the concatenation of the -``s`` argument and the fixed suffix. I.e. ``with_suffix_expr "some_dynamic_stem"`` is equivalent to -``[%expr "some_dynamic_steme" ^ "some_fixed_suffix"]``. - -Similarly if you want to ignore some parts of AST nodes and extract some others when -pattern-matching over them, you can use anti-quotation: - -.. code:: ocaml - - match some_expr_node with - | [%expr 1 + [%e? _] + [%e? third]] -> do_something_with third - -The syntax for anti-quotation depends on the type of the node you wish to insert: - -- ``e`` to anti-quote values of type ``Parsetree.expression``: ``[%expr 1 + [%e some_expr_node]]`` -- ``p`` to anti-quote values of type ``Parsetree.pattern``: - ``[%pat? (1, [%p some_pat_node]]`` -- ``t`` to anti-quote values of type ``Parsetree.core_type``: - ``[%type: int -> [%t some_core_type_node]]`` -- ``m`` to anti-quote values of type ``Parsetree.module_expr`` or ``module_type``: - ``[%expr let module M = [%m some_module_expr_node]]`` or - ``[%sigi: module M : [%m some_module_type_node]]`` -- ``i`` to anti-quote values of type ``Parsetree.structure_item`` or ``signature_item``: - ``[%str let a = 1 [%%i some_structure_item_node]]`` or - ``[%sig: val a : int [%%i some_signature_item_node]]`` - -Note that when anti-quoting in a pattern context you must always use the ``?`` in the anti-quotation -extension as its payload should always be a pattern the same way it must always be an expression -in an expression context. - -As you may have noticed, you can anti-quote expressions which type differs from the type of the -whole ``metaquot`` extension point. E.g. you can write: - -.. code:: ocaml - - let structure_item = - [%stri let [%p some_pat] : [%t some_type] = [%e some_expr]] diff -Nru ppxlib-0.24.0/doc/what-is-ppx.rst ppxlib-0.27.0/doc/what-is-ppx.rst --- ppxlib-0.24.0/doc/what-is-ppx.rst 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/doc/what-is-ppx.rst 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ - -************ -What is PPX? -************ - -.. _ppx-overview: - -Overview --------- - -Ppx is a meta-programming system for the OCaml programming -language. It allows developers to generate code at compile time in a -principled way. The distinguishing feature of ppx is that it is -tightly integrated with the OCaml parser and instead of operating at -the text level it operates on the internal structured representation -of the language in the compiler, called the Abstract Syntax Tree or -AST for short. - -A few years ago, the OCaml language was extended with two new -constructions: annotations and extension points. Annotations are -arbitrary pieces of information that can be attached to most parts of -the OCaml language. They can be used to control the behavior of the -OCaml compiler, or in some specific cases to generate code at compile -time. - -Extension points are compile time functions. The compiler itself -doesn't know how to interpret them and they must all be rewritten by -the ppx system before the compiler can process input files further. - -Ppxlib mainly supports two ways of generating code at compile time: by -expanding an extension point or by expanding a ``[@@deriving ...]`` -attribute after a type declaration. - -How does it works? ------------------- - -The ppx system is composed of 3 parts: - -- individual ppx rewriters -- ppxlib -- a hook in the compiler - -Inidividual ppx rewriters are those implemented by various developers -to provide features to end users, such as ppx_expect_ which provides a -good inline testing framework. - -All these rewriters are written against the ppxlib API. Ppxlib is -responsible for acknowledging the various rewriters a end user wants -to use, making sure they can be composed together and performing the -actual rewriting of input files. - -The hook in the compiler allows ppxlib to insert itself in the -compilation pipeline and perform the rewriting of input files based on -a list of ppx rewriters specified by the user. The hooks take the form -of command line flags that takes a command to execute. The compiler -supports two slightly different flags, for providing commands that are -executed at different stages: ``-pp`` and ``-ppx``. The difference -between the two is as follow: - -- ``-pp`` takes as argument a command that is used to parse the - textual representation. Such a command can produce either a plain - OCaml source file or a serialised representation of the AST - -- ``-ppx`` takes as argument a command that is given a serialised - representation of the AST and produces another serialised AST - -Ppxlib generally uses the first one as it yields faster compilation -times, however it supports both methods of operation. - -Is ppxlib necessary? --------------------- - -Yes. While authors of ppx rewriters may in theory use the compiler -hooks directly, doing so is strongly discouraged for the following -reasons: - -- composing such ppx rewriters is slow and yields much slower - compilation times -- the ABI of the hook is not stable and regularly changes in - incompatible ways. This means that a ppx rewriter using the compiler - hook directly is likely to work only with a single version of the - OCaml compiler -- the compiler does not provide a good composition semantics, which - means that input files will not always be transformed as - expected. It is hard to predict what the final result will be, and - for end users it is hard to understand what is happening when things - go wrong -- the compiler doesn't handle hygiene: if an attribute is mistyped or - misplaced, it is silently ignored by the compiler. If two ppx - rewriters want to interpret the same attribute or extension point in - incompatible ways, the result is not specified - -In summary, ppxlib abstracts away from all the low-level details of -the ppx system and exposes a consistent model to authors of ppx -rewriters and end users. - -Current state of the ppx ecosystem ----------------------------------- - -Ppxlib was developed after the introduction of the ppx system. As a -result, many ppx rewriters do not currently use ppxlib and are using -the compiler hooks directly. Ppxlib can acknowledge such rewriters so -that they can be used in conjunction with more modern rewriters, -however it cannot provide a good composition or hygiene story when -using such ppx rewriters. - -Note on stability regarding new compiler releases -------------------------------------------------- - -Due to the nature of the ppx system, it is hard for ppxlib to provide -full protection against compiler changes. This means that a ppx -rewriter written against ppxlib today can be broken by a future -release of the OCaml compiler and a new release of the ppx rewriter -will be necessary to support the new compiler. - -However the following is true: every time this might happen, it will be -possible to extend ppxlib to provide a greater protection, so that -eventually the whole ppx ecosystem is completely shielded from -breaking compiler changes. - -.. _ppx_expect: https://github.com/janestreet/ppx_expect - diff -Nru ppxlib-0.24.0/dune-project ppxlib-0.27.0/dune-project --- ppxlib-0.24.0/dune-project 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/dune-project 2022-06-14 18:16:33.000000000 +0000 @@ -1,6 +1,6 @@ (lang dune 2.7) (name ppxlib) -(version 0.24.0) +(version 0.27.0) (using cinaps 1.0) (allow_approximate_merlin) (implicit_transitive_deps false) @@ -16,10 +16,11 @@ (package (name ppxlib) (depends - (ocaml (and (>= 4.04.1) (< 4.15))) + (ocaml (and (>= 4.04.1) (< 5.1.0))) (ocaml-compiler-libs (>= v0.11.0)) (ppx_derivers (>= 1.0)) (sexplib0 (>= v0.12)) + (sexplib0 (and :with-test (< "v0.15"))) ; Printexc.register_printer in sexplib0 changed stdlib-shims (ocamlfind :with-test) (re (and :with-test (>= 1.9.0))) @@ -31,7 +32,7 @@ base-effects) (synopsis "Standard library for ppx rewriters") (description "Ppxlib is the standard library for ppx rewriters and other programs -that manipulate the in-memory reprensation of OCaml programs, a.k.a +that manipulate the in-memory representation of OCaml programs, a.k.a the \"Parsetree\". It also comes bundled with two ppx rewriters that are commonly used to diff -Nru ppxlib-0.24.0/examples/simple-deriver/ppx_deriving_accessors.ml ppxlib-0.27.0/examples/simple-deriver/ppx_deriving_accessors.ml --- ppxlib-0.24.0/examples/simple-deriver/ppx_deriving_accessors.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/examples/simple-deriver/ppx_deriving_accessors.ml 2022-06-14 18:16:33.000000000 +0000 @@ -37,9 +37,16 @@ let loc = Expansion_context.Deriver.derived_item_loc ctxt in List.map type_declarations ~f:(fun (td : type_declaration) -> match td with - | { ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; _ } -> - Location.raise_errorf ~loc - "Cannot derive accessors for non record types" + | { + ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; + ptype_loc; + _; + } -> + let ext = + Location.error_extensionf ~loc:ptype_loc + "Cannot derive accessors for non record types" + in + [ Ast_builder.Default.pstr_extension ~loc ext [] ] | { ptype_kind = Ptype_record fields; _ } -> List.map fields ~f:accessor_impl) |> List.concat @@ -48,15 +55,21 @@ let loc = Expansion_context.Deriver.derived_item_loc ctxt in List.map type_declarations ~f:(fun (td : type_declaration) -> match td with - | { ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; _ } -> - Location.raise_errorf ~loc - "Cannot derive accessors for non record types" + | { + ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; + ptype_loc; + _; + } -> + let ext = + Location.error_extensionf ~loc:ptype_loc + "Cannot derive accessors for non record types" + in + [ Ast_builder.Default.psig_extension ~loc ext [] ] | { ptype_kind = Ptype_record fields; ptype_name; _ } -> List.map fields ~f:(accessor_intf ~ptype_name)) |> List.concat let impl_generator = Deriving.Generator.V2.make_noarg generate_impl - let intf_generator = Deriving.Generator.V2.make_noarg generate_intf let my_deriver = diff -Nru ppxlib-0.24.0/examples/simple-extension-rewriter/ppx_get_env.ml ppxlib-0.27.0/examples/simple-extension-rewriter/ppx_get_env.ml --- ppxlib-0.24.0/examples/simple-extension-rewriter/ppx_get_env.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/examples/simple-extension-rewriter/ppx_get_env.ml 2022-06-14 18:16:33.000000000 +0000 @@ -5,8 +5,11 @@ match Sys.getenv env_var with | value -> Ast_builder.Default.estring ~loc value | exception Not_found -> - Location.raise_errorf ~loc "The environement variable %s is unbound" - env_var + let ext = + Location.error_extensionf ~loc "The environement variable %s is unbound" + env_var + in + Ast_builder.Default.pexp_extension ~loc ext let my_extension = Extension.V3.declare "get_env" Extension.Context.expression @@ -14,5 +17,4 @@ expand let rule = Ppxlib.Context_free.Rule.extension my_extension - let () = Driver.register_transformation ~rules:[ rule ] "get_env" diff -Nru ppxlib-0.24.0/.git-blame-ignore-revs ppxlib-0.27.0/.git-blame-ignore-revs --- ppxlib-0.24.0/.git-blame-ignore-revs 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/.git-blame-ignore-revs 2022-06-14 18:16:33.000000000 +0000 @@ -1,2 +1,5 @@ # The bulk change commit enabling ocamlformat 427f96e126d306538eb541ac591f71b2c68e5dd4 + +#The commit upgrading to ocamlformat 0.20.0 +50c1f3736e58be5cf18ad02debf9653799625bfc diff -Nru ppxlib-0.24.0/.github/CODEOWNERS ppxlib-0.27.0/.github/CODEOWNERS --- ppxlib-0.24.0/.github/CODEOWNERS 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/.github/CODEOWNERS 2022-06-14 18:16:33.000000000 +0000 @@ -1 +1 @@ -* @ceastlund @NathanReb @pitag-ha +* @ceastlund @panglesd @pitag-ha diff -Nru ppxlib-0.24.0/HISTORY.md ppxlib-0.27.0/HISTORY.md --- ppxlib-0.24.0/HISTORY.md 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/HISTORY.md 2022-06-14 18:16:33.000000000 +0000 @@ -68,7 +68,7 @@ Other ASTs ---------- If you want to write code that works with several versions of -`Ppxlib` using different AST versions, you can use the versionned +`Ppxlib` using different AST versions, you can use the versioned alternatives for `Ast_builder` and `Ast_pattern`. For instance: ``` diff -Nru ppxlib-0.24.0/Makefile ppxlib-0.27.0/Makefile --- ppxlib-0.24.0/Makefile 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/Makefile 2022-06-14 18:16:33.000000000 +0000 @@ -16,11 +16,7 @@ dune runtest doc: - cd doc && sphinx-build . _build - -livedoc: - cd doc && sphinx-autobuild . _build \ - -p 8888 -q --host $(shell hostname) -r '\.#.*' + dune build @doc clean: dune clean diff -Nru ppxlib-0.24.0/metaquot/dune ppxlib-0.27.0/metaquot/dune --- ppxlib-0.24.0/metaquot/dune 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/metaquot/dune 2022-06-14 18:16:33.000000000 +0000 @@ -4,4 +4,5 @@ (kind ppx_rewriter) (flags (:standard -safe-string)) - (libraries ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters)) + (libraries ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters) + (ppx_runtime_libraries ppxlib_ast)) diff -Nru ppxlib-0.24.0/metaquot/ppxlib_metaquot.ml ppxlib-0.27.0/metaquot/ppxlib_metaquot.ml --- ppxlib-0.24.0/metaquot/ppxlib_metaquot.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/metaquot/ppxlib_metaquot.ml 2022-06-14 18:16:33.000000000 +0000 @@ -6,23 +6,27 @@ module Make (M : sig type result + val annotate : result -> core_type -> result val cast : extension -> result - val location : location -> result - val location_stack : (location -> result) option - val attributes : (location -> result) option class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters end) = struct let lift loc = - object + object (self) inherit [M.result] Ast_traverse.lift as super - inherit! M.std_lifters loc + method typed ast name = + let loc = { loc with loc_ghost = true } in + M.annotate ast + (ptyp_constr ~loc + { loc; txt = Ldot (Ldot (Lident "Ppxlib_ast", "Ast"), name) } + []) + method! attribute x = Attribute.mark_as_handled_manually x; super#attribute x @@ -43,41 +47,46 @@ method! expression e = match e.pexp_desc with - | Pexp_extension (({ txt = "e"; _ }, _) as ext) -> M.cast ext + | Pexp_extension (({ txt = "e"; _ }, _) as ext) -> + self#typed (M.cast ext) "expression" | _ -> super#expression e method! pattern p = match p.ppat_desc with - | Ppat_extension (({ txt = "p"; _ }, _) as ext) -> M.cast ext + | Ppat_extension (({ txt = "p"; _ }, _) as ext) -> + self#typed (M.cast ext) "pattern" | _ -> super#pattern p method! core_type t = match t.ptyp_desc with - | Ptyp_extension (({ txt = "t"; _ }, _) as ext) -> M.cast ext + | Ptyp_extension (({ txt = "t"; _ }, _) as ext) -> + self#typed (M.cast ext) "core_type" | _ -> super#core_type t method! module_expr m = match m.pmod_desc with - | Pmod_extension (({ txt = "m"; _ }, _) as ext) -> M.cast ext + | Pmod_extension (({ txt = "m"; _ }, _) as ext) -> + self#typed (M.cast ext) "module_expr" | _ -> super#module_expr m method! module_type m = match m.pmty_desc with - | Pmty_extension (({ txt = "m"; _ }, _) as ext) -> M.cast ext + | Pmty_extension (({ txt = "m"; _ }, _) as ext) -> + self#typed (M.cast ext) "module_type" | _ -> super#module_type m method! structure_item i = match i.pstr_desc with | Pstr_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> assert_no_attributes attrs; - M.cast ext + self#typed (M.cast ext) "structure_item" | _ -> super#structure_item i method! signature_item i = match i.psig_desc with | Psig_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> assert_no_attributes attrs; - M.cast ext + self#typed (M.cast ext) "signature_item" | _ -> super#signature_item i end end @@ -86,13 +95,13 @@ type result = expression let location loc = evar ~loc:{ loc with loc_ghost = true } "loc" - let location_stack = None - let attributes = None class std_lifters = Ppxlib_metaquot_lifters.expression_lifters + let annotate e core_type = pexp_constraint ~loc:core_type.ptyp_loc e core_type + let cast ext = match snd ext with | PStr [ { pstr_desc = Pstr_eval (e, attrs); _ } ] -> @@ -114,6 +123,8 @@ class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters + let annotate p core_type = ppat_constraint ~loc:core_type.ptyp_loc p core_type + let cast ext = match snd ext with | PPat (p, None) -> p @@ -127,25 +138,39 @@ [ E.declare "metaquot.expr" ctx A.(single_expr_payload __) - (fun ~loc ~path:_ e -> (lifter loc)#expression e); + (fun ~loc ~path:_ e -> + let lift = lifter loc in + lift#typed (lift#expression e) "expression"); E.declare "metaquot.pat" ctx A.(ppat __ none) - (fun ~loc ~path:_ p -> (lifter loc)#pattern p); + (fun ~loc ~path:_ p -> + let lift = lifter loc in + lift#typed (lift#pattern p) "pattern"); E.declare "metaquot.str" ctx A.(pstr __) - (fun ~loc ~path:_ s -> (lifter loc)#structure s); + (fun ~loc ~path:_ s -> + let lift = lifter loc in + lift#typed (lift#structure s) "structure"); E.declare "metaquot.stri" ctx A.(pstr (__ ^:: nil)) - (fun ~loc ~path:_ s -> (lifter loc)#structure_item s); + (fun ~loc ~path:_ s -> + let lift = lifter loc in + lift#typed (lift#structure_item s) "structure_item"); E.declare "metaquot.sig" ctx A.(psig __) - (fun ~loc ~path:_ s -> (lifter loc)#signature s); + (fun ~loc ~path:_ s -> + let lift = lifter loc in + lift#typed (lift#signature s) "signature"); E.declare "metaquot.sigi" ctx A.(psig (__ ^:: nil)) - (fun ~loc ~path:_ s -> (lifter loc)#signature_item s); + (fun ~loc ~path:_ s -> + let lift = lifter loc in + lift#typed (lift#signature_item s) "signature_item"); E.declare "metaquot.type" ctx A.(ptyp __) - (fun ~loc ~path:_ t -> (lifter loc)#core_type t); + (fun ~loc ~path:_ t -> + let lift = lifter loc in + lift#typed (lift#core_type t) "core_type"); ] in let extensions = diff -Nru ppxlib-0.24.0/metaquot_lifters/ppxlib_metaquot_lifters.ml ppxlib-0.27.0/metaquot_lifters/ppxlib_metaquot_lifters.ml --- ppxlib-0.24.0/metaquot_lifters/ppxlib_metaquot_lifters.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/metaquot_lifters/ppxlib_metaquot_lifters.ml 2022-06-14 18:16:33.000000000 +0000 @@ -17,28 +17,19 @@ (match args with [] -> None | l -> Some (pexp_tuple ~loc l)) method tuple l = pexp_tuple ~loc l - method int i = eint ~loc i - method int32 i = eint32 ~loc i - method int64 i = eint64 ~loc i - method nativeint i = enativeint ~loc i - method float f = efloat ~loc (Float.to_string f) - method string s = estring ~loc s - method char c = echar ~loc c - method bool b = ebool ~loc b method array : 'a. ('a -> expression) -> 'a array -> expression = fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f) method unit () = eunit ~loc - method other : 'a. 'a -> expression = fun _ -> failwith "not supported" end @@ -57,27 +48,18 @@ (match args with [] -> None | l -> Some (ppat_tuple ~loc l)) method tuple l = ppat_tuple ~loc l - method int i = pint ~loc i - method int32 i = pint32 ~loc i - method int64 i = pint64 ~loc i - method nativeint i = pnativeint ~loc i - method float f = pfloat ~loc (Float.to_string f) - method string s = pstring ~loc s - method char c = pchar ~loc c - method bool b = pbool ~loc b method array : 'a. ('a -> pattern) -> 'a array -> pattern = fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f) method unit () = punit ~loc - method other : 'a. 'a -> pattern = fun _ -> failwith "not supported" end diff -Nru ppxlib-0.24.0/.ocamlformat ppxlib-0.27.0/.ocamlformat --- ppxlib-0.24.0/.ocamlformat 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/.ocamlformat 2022-06-14 18:16:33.000000000 +0000 @@ -1,3 +1,3 @@ -version=0.19.0 +version=0.20.0 profile=conventional parse-docstrings=true diff -Nru ppxlib-0.24.0/.ocamlformat-ignore ppxlib-0.27.0/.ocamlformat-ignore --- ppxlib-0.24.0/.ocamlformat-ignore 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/.ocamlformat-ignore 2022-06-14 18:16:33.000000000 +0000 @@ -31,9 +31,11 @@ test/driver/instrument/test.ml test/driver/non-compressible-suffix/test.ml test/driver/transformations/test.ml +test/expand-header-and-footer/test.ml test/expansion_inside_payloads/test.ml test/extensions_and_deriving/test.ml test/location/exception/test.ml +test/metaquot/test.ml test/ppx_import_support/test.ml test/quoter/test.ml test/traverse/test.ml diff -Nru ppxlib-0.24.0/ppxlib.opam ppxlib-0.27.0/ppxlib.opam --- ppxlib-0.24.0/ppxlib.opam 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/ppxlib.opam 2022-06-14 18:16:33.000000000 +0000 @@ -1,10 +1,10 @@ -version: "0.24.0" +version: "0.27.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Standard library for ppx rewriters" description: """ Ppxlib is the standard library for ppx rewriters and other programs -that manipulate the in-memory reprensation of OCaml programs, a.k.a +that manipulate the in-memory representation of OCaml programs, a.k.a the "Parsetree". It also comes bundled with two ppx rewriters that are commonly used to @@ -22,10 +22,11 @@ bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" depends: [ "dune" {>= "2.7"} - "ocaml" {>= "4.04.1" & < "4.15"} + "ocaml" {>= "4.04.1" & < "5.1.0"} "ocaml-compiler-libs" {>= "v0.11.0"} "ppx_derivers" {>= "1.0"} "sexplib0" {>= "v0.12"} + "sexplib0" {with-test & < "v0.15"} "stdlib-shims" "ocamlfind" {with-test} "re" {with-test & >= "1.9.0"} diff -Nru ppxlib-0.24.0/src/ast_builder_intf.ml ppxlib-0.27.0/src/ast_builder_intf.ml --- ppxlib-0.24.0/src/ast_builder_intf.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_builder_intf.ml 2022-06-14 18:16:33.000000000 +0000 @@ -8,39 +8,22 @@ type 'a with_loc val eint : (int -> expression) with_loc - val echar : (char -> expression) with_loc - val estring : (string -> expression) with_loc - val efloat : (string -> expression) with_loc - val eint32 : (int32 -> expression) with_loc - val eint64 : (int64 -> expression) with_loc - val enativeint : (nativeint -> expression) with_loc - val ebool : (bool -> expression) with_loc - val pint : (int -> pattern) with_loc - val pchar : (char -> pattern) with_loc - val pstring : (string -> pattern) with_loc - val pfloat : (string -> pattern) with_loc - val pint32 : (int32 -> pattern) with_loc - val pint64 : (int64 -> pattern) with_loc - val pnativeint : (nativeint -> pattern) with_loc - val pbool : (bool -> pattern) with_loc - val eunit : expression with_loc - val punit : pattern with_loc val evar : (string -> expression) with_loc @@ -54,19 +37,12 @@ (** Same as pexp_apply but without labels *) val eabstract : (pattern list -> expression -> expression) with_loc - val esequence : (expression list -> expression) with_loc - val ppat_tuple_opt : (pattern list -> pattern option) with_loc - val pexp_tuple_opt : (expression list -> expression option) with_loc - val pconstruct : constructor_declaration -> pattern option -> pattern - val econstruct : constructor_declaration -> expression option -> expression - val elist : (expression list -> expression) with_loc - val plist : (pattern list -> pattern) with_loc val pstr_value_list : @@ -138,22 +114,16 @@ module type Located = sig type 'a with_loc - type 'a t = 'a Loc.t val loc : _ t -> Location.t - val mk : ('a -> 'a t) with_loc - val map : ('a -> 'b) -> 'a t -> 'b t - val map_lident : string t -> Longident.t t - val lident : (string -> Longident.t t) with_loc end type 'a without_location = 'a - type 'a with_location = loc:Location.t -> 'a module type S = sig diff -Nru ppxlib-0.24.0/src/ast_builder.ml ppxlib-0.27.0/src/ast_builder.ml --- ppxlib-0.24.0/src/ast_builder.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_builder.ml 2022-06-14 18:16:33.000000000 +0000 @@ -5,18 +5,42 @@ type 'a t = 'a Loc.t let loc (x : _ t) = x.loc - let mk ~loc x = { loc; txt = x } - let map f t = { t with txt = f t.txt } - let map_lident x = map (fun x -> Longident.Lident x) x - let lident ~loc x = mk ~loc (Longident.parse x) end include Ast_builder_generated.M + module Latest = struct + let ppat_construct = ppat_construct + + let constructor_declaration ~loc ~name ~vars ~args ~res () = + constructor_declaration ~loc ~name ~vars ~args ~res + end + + (*------ stable layer above Ast_builder_generated.M -----*) + let ppat_construct ~loc lid p = + { + ppat_loc_stack = []; + ppat_attributes = []; + ppat_loc = loc; + ppat_desc = Ppat_construct (lid, Option.map p ~f:(fun p -> ([], p))); + } + + let constructor_declaration ~loc ~name ~args ~res = + { + pcd_name = name; + pcd_vars = []; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = []; + } + + (*-------------------------------------------------------*) + let pstr_value_list ~loc rec_flag = function | [] -> [] | vbs -> [ pstr_value ~loc rec_flag vbs ] @@ -27,11 +51,8 @@ "Ppxlib.Ast_builder.nonrec_type_declaration: don't use this function" let eint ~loc t = pexp_constant ~loc (Pconst_integer (Int.to_string t, None)) - let echar ~loc t = pexp_constant ~loc (Pconst_char t) - let estring ~loc t = pexp_constant ~loc (Pconst_string (t, loc, None)) - let efloat ~loc t = pexp_constant ~loc (Pconst_float (t, None)) let eint32 ~loc t = @@ -44,11 +65,8 @@ pexp_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) let pint ~loc t = ppat_constant ~loc (Pconst_integer (Int.to_string t, None)) - let pchar ~loc t = ppat_constant ~loc (Pconst_char t) - let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, loc, None)) - let pfloat ~loc t = ppat_constant ~loc (Pconst_float (t, None)) let pint32 ~loc t = @@ -67,17 +85,11 @@ ppat_construct ~loc (Located.lident ~loc (Bool.to_string t)) None let evar ~loc v = pexp_ident ~loc (Located.mk ~loc (Longident.parse v)) - let pvar ~loc v = ppat_var ~loc (Located.mk ~loc v) - let eunit ~loc = pexp_construct ~loc (Located.lident ~loc "()") None - let punit ~loc = ppat_construct ~loc (Located.lident ~loc "()") None - let pexp_tuple ~loc l = match l with [ x ] -> x | _ -> pexp_tuple ~loc l - let ppat_tuple ~loc l = match l with [ x ] -> x | _ -> ppat_tuple ~loc l - let ptyp_tuple ~loc l = match l with [ x ] -> x | _ -> ptyp_tuple ~loc l let pexp_tuple_opt ~loc l = @@ -269,13 +281,65 @@ module type Loc = Ast_builder_intf.Loc -module type S = Ast_builder_intf.S +module type S = sig + include Ast_builder_intf.S + + module Latest : sig + val ppat_construct : + longident loc -> (label loc list * pattern) option -> pattern + + val constructor_declaration : + name:label loc -> + vars:label loc list -> + args:constructor_arguments -> + res:core_type option -> + unit -> + constructor_declaration + end + + val ppat_construct : longident loc -> pattern option -> pattern + + val constructor_declaration : + name:label loc -> + args:constructor_arguments -> + res:core_type option -> + constructor_declaration +end module Make (Loc : sig val loc : Location.t end) : S = struct include Ast_builder_generated.Make (Loc) + module Latest = struct + let ppat_construct = ppat_construct + + let constructor_declaration ~name ~vars ~args ~res () = + constructor_declaration ~name ~vars ~args ~res + end + + (*----- stable layer above Ast_builder_generated.Make (Loc) -----*) + + let ppat_construct lid p = + { + ppat_loc_stack = []; + ppat_attributes = []; + ppat_loc = loc; + ppat_desc = Ppat_construct (lid, Option.map p ~f:(fun p -> ([], p))); + } + + let constructor_declaration ~name ~args ~res = + { + pcd_name = name; + pcd_vars = []; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = []; + } + + (*---------------------------------------------------------------*) + let pstr_value_list = Default.pstr_value_list let nonrec_type_declaration ~name ~params ~cstrs ~kind ~private_ ~manifest = @@ -286,78 +350,43 @@ include Default.Located let loc _ = Loc.loc - let mk x = mk ~loc:Loc.loc x - let lident x = lident ~loc:Loc.loc x end let pexp_tuple l = Default.pexp_tuple ~loc l - let ppat_tuple l = Default.ppat_tuple ~loc l - let ptyp_tuple l = Default.ptyp_tuple ~loc l - let pexp_tuple_opt l = Default.pexp_tuple_opt ~loc l - let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l - let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty - let pexp_apply e el = Default.pexp_apply ~loc e el - let eint t = Default.eint ~loc t - let echar t = Default.echar ~loc t - let estring t = Default.estring ~loc t - let efloat t = Default.efloat ~loc t - let eint32 t = Default.eint32 ~loc t - let eint64 t = Default.eint64 ~loc t - let enativeint t = Default.enativeint ~loc t - let ebool t = Default.ebool ~loc t - let evar t = Default.evar ~loc t - let pint t = Default.pint ~loc t - let pchar t = Default.pchar ~loc t - let pstring t = Default.pstring ~loc t - let pfloat t = Default.pfloat ~loc t - let pint32 t = Default.pint32 ~loc t - let pint64 t = Default.pint64 ~loc t - let pnativeint t = Default.pnativeint ~loc t - let pbool t = Default.pbool ~loc t - let pvar t = Default.pvar ~loc t - let eunit = Default.eunit ~loc - let punit = Default.punit ~loc - let econstruct = Default.econstruct - let pconstruct = Default.pconstruct - let eapply e el = Default.eapply ~loc e el - let eabstract ps e = Default.eabstract ~loc ps e - let esequence el = Default.esequence ~loc el - let elist l = Default.elist ~loc l - let plist l = Default.plist ~loc l let type_constr_conv ident ~f args = @@ -367,7 +396,6 @@ Default.unapplied_type_constr_conv ~loc ident ~f let eta_reduce = Default.eta_reduce - let eta_reduce_if_possible = Default.eta_reduce_if_possible let eta_reduce_if_possible_and_nonrec = diff -Nru ppxlib-0.24.0/src/ast_builder.mli ppxlib-0.27.0/src/ast_builder.mli --- ppxlib-0.24.0/src/ast_builder.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_builder.mli 2022-06-14 18:16:33.000000000 +0000 @@ -86,6 +86,41 @@ include module type of Ast_builder_generated.M + module Latest : sig + (** This module contains updated versions of node constructors that were + kept stable when the node changed. For every function in this module, + there's an equally-named function outside this module. The function + outside this module will stay stable, whereas the function inside this + module will adapt potential upcoming new compiler features. Only use a + function in this module, if the equally-named one outside this module is + missing a feature you need. *) + + val ppat_construct : + loc:location -> + longident loc -> + (label loc list * pattern) option -> + pattern + + val constructor_declaration : + loc:location -> + name:label loc -> + vars:label loc list -> + args:constructor_arguments -> + res:core_type option -> + unit -> + constructor_declaration + end + + val ppat_construct : + loc:location -> longident loc -> pattern option -> pattern + + val constructor_declaration : + loc:location -> + name:label loc -> + args:constructor_arguments -> + res:core_type option -> + constructor_declaration + include Ast_builder_intf.Additional_helpers with type 'a with_loc := 'a Ast_builder_intf.with_location @@ -93,7 +128,38 @@ module type Loc = Ast_builder_intf.Loc -module type S = Ast_builder_intf.S +module type S = sig + include Ast_builder_intf.S + + module Latest : sig + (** This module contains updated versions of node constructors that were + kept stable when the node changed. For every function in this module, + there's an equally-named function outside this module. The function + outside this module will stay stable, whereas the function inside this + module will adapt potential upcoming new compiler features. Only use a + function in this module, if the equally-named one outside this module is + missing a feature you need. *) + + val ppat_construct : + longident loc -> (label loc list * pattern) option -> pattern + + val constructor_declaration : + name:label loc -> + vars:label loc list -> + args:constructor_arguments -> + res:core_type option -> + unit -> + constructor_declaration + end + + val ppat_construct : longident loc -> pattern option -> pattern + + val constructor_declaration : + name:label loc -> + args:constructor_arguments -> + res:core_type option -> + constructor_declaration +end (** Build Ast helpers with the location argument factorized. *) module Make (Loc : Loc) : S diff -Nru ppxlib-0.24.0/src/ast_pattern.ml ppxlib-0.27.0/src/ast_pattern.ml --- ppxlib-0.24.0/src/ast_pattern.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_pattern.ml 2022-06-14 18:16:33.000000000 +0000 @@ -2,23 +2,26 @@ include Ast_pattern0 let save_context ctx = ctx.matched - let restore_context ctx backup = ctx.matched <- backup - let incr_matched c = c.matched <- c.matched + 1 -let parse (T f) loc ?on_error x k = - try f { matched = 0 } loc x k +let parse_res (T f) loc ?on_error x k = + try Ok (f { matched = 0 } loc x k) with Expected (loc, expected) -> ( match on_error with - | None -> Location.raise_errorf ~loc "%s expected" expected - | Some f -> f ()) + | None -> Error (Location.Error.createf ~loc "%s expected" expected, []) + | Some f -> Ok (f ())) + +let parse (T f) loc ?on_error x k = + match parse_res (T f) loc ?on_error x k with + | Ok r -> r + | Error (r, _) -> Location.Error.raise r module Packed = struct type ('a, 'b) t = T : ('a, 'b, 'c) Ast_pattern0.t * 'b -> ('a, 'c) t let create t f = T (t, f) - + let parse_res (T (t, f)) loc x = parse_res t loc x f let parse (T (t, f)) loc x = parse t loc x f end @@ -40,6 +43,12 @@ incr_matched ctx; k) +let as__ (T f1) = + T + (fun ctx loc x k -> + let k = f1 ctx loc x (k x) in + k) + let cst ~to_string ?(equal = Poly.equal) v = T (fun ctx loc x k -> @@ -49,19 +58,12 @@ else fail loc (to_string v)) let int v = cst ~to_string:Int.to_string v - let char v = cst ~to_string:(Printf.sprintf "%C") v - let string v = cst ~to_string:(Printf.sprintf "%S") v - let float v = cst ~to_string:Float.to_string v - let int32 v = cst ~to_string:Int32.to_string v - let int64 v = cst ~to_string:Int64.to_string v - let nativeint v = cst ~to_string:Nativeint.to_string v - let bool v = cst ~to_string:Bool.to_string v let false_ = @@ -155,17 +157,11 @@ else raise e2)) let ( ||| ) = alt - let map (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f k)) - let map' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f loc k)) - let map_result (T func) ~f = T (fun ctx loc x k -> f (func ctx loc x k)) - 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 = @@ -183,65 +179,47 @@ 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)))) + T + (fun ctx loc l k -> + let rec aux accu = function + | [] -> k (List.rev accu) + | x :: xs -> f ctx loc x (fun x -> aux (x :: accu) xs) + in + aux [] l) let loc (T f) = T (fun ctx _loc (x : _ Loc.t) k -> f ctx x.loc x.txt k) - let pack0 t = map t ~f:(fun f -> f ()) - let pack2 t = map t ~f:(fun f x y -> f (x, y)) - let pack3 t = map t ~f:(fun f x y z -> f (x, y, z)) include Ast_pattern_generated let echar t = pexp_constant (pconst_char t) - let estring t = pexp_constant (pconst_string t drop 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 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 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 = cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel") ** t let extension (T f1) (T f2) = @@ -282,5 +260,4 @@ f ctx expr.pexp_loc expr (fun x -> x)))) let of_func f = T f - let to_func (T f) = f diff -Nru ppxlib-0.24.0/src/ast_pattern.mli ppxlib-0.27.0/src/ast_pattern.mli --- ppxlib-0.24.0/src/ast_pattern.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_pattern.mli 2022-06-14 18:16:33.000000000 +0000 @@ -66,7 +66,12 @@ which means that it matches values of type [payload] and captures a string and expression from it. The two captured elements comes from the use of - [__]. *) + [__]. + + An empty payload (e.g. for an attribute that has no payload) is matched by + [Ast_pattern.(pstr nil)]. A payload with exactly one expression (e.g. to + specify a custom function in a deriver) is matched by + [Ast_pattern.(single_expr_payload __)]. *) type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t (** Type of a pattern: @@ -78,16 +83,29 @@ val parse : ('a, 'b, 'c) t -> Location.t -> ?on_error:(unit -> 'c) -> 'a -> 'b -> 'c -(** Matches a value against a pattern. *) +(** Matches a value against a pattern. Raise a located error in case of failure. *) + +val parse_res : + ('a, 'b, 'c) t -> + Location.t -> + ?on_error:(unit -> 'c) -> + 'a -> + 'b -> + ('c, Location.Error.t NonEmptyList.t) result +(** Matches a value against a pattern and return a result. *) module Packed : sig type ('a, 'b, 'c) pattern = ('a, 'b, 'c) t - type ('a, 'b) t val create : ('a, 'b, 'c) pattern -> 'b -> ('a, 'c) t - val parse : ('a, 'b) t -> Location.t -> 'a -> 'b + + val parse_res : + ('a, 'b) t -> + Location.t -> + 'a -> + ('b, Location.Error.t NonEmptyList.t) result end with type ('a, 'b, 'c) pattern := ('a, 'b, 'c) t @@ -109,6 +127,19 @@ In the latter case you should use the [pexp_loc] field of the captured expression instead. *) +val drop : ('a, 'b, 'b) t +(** Useful when some part of the AST is irrelevant. With [__], the captured + value is passed to the continuation, with [drop] it is ignored. In + higher-level pattern matching, it is called wildcard pattern. *) + +val as__ : ('a, 'b, 'c) t -> ('a, 'a -> 'b, 'c) t +(** As-pattern. Passes the current node to the continuation. + + Pitfall. In general, the continuation is called step by step by being + applied partially to every next captured node in the pattern. That means + that the node captured by [as__] is passed to the continuation before + checking if the pattern is matched. *) + val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t (** [alt] stands for `alternatives'. It matches either the first pattern or the second one. *) @@ -122,16 +153,13 @@ (** Same as [alt] *) val map : ('a, 'b, 'c) t -> f:('d -> 'b) -> ('a, 'd, 'c) t - val map' : ('a, 'b, 'c) t -> f:(Location.t -> 'd -> 'b) -> ('a, 'd, 'c) t - val map_result : ('a, 'b, 'c) t -> f:('c -> 'd) -> ('a, 'b, 'd) t val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t (** Same as [map] *) 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 : @@ -148,36 +176,23 @@ ('a, 'v -> 'b, 'c) t val nil : (_ list, 'a, 'a) 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 - +val many : ('a, 'b -> 'c, 'c) t -> ('a list, 'b list -> 'c, 'c) t val int : int -> (int, 'a, 'a) t - val char : char -> (char, 'a, 'a) t - val string : string -> (string, 'a, 'a) t - val float : float -> (float, 'a, 'a) t - val int32 : int32 -> (int32, 'a, 'a) t - val int64 : int64 -> (int64, 'a, 'a) t - val nativeint : nativeint -> (nativeint, 'a, 'a) t - val bool : bool -> (bool, 'a, 'a) t val cst : to_string:('a -> string) -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b, 'b) t val none : (_ option, 'a, 'a) t - val some : ('a, 'b, 'c) t -> ('a option, 'b, 'c) t - val pair : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t - val ( ** ) : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t val triple : @@ -187,11 +202,8 @@ ('a1 * 'a2 * 'a3, 'b, 'e) t val loc : ('a, 'b, 'c) t -> ('a Loc.t, 'b, 'c) t - val pack0 : ('a, 'b, 'c) t -> ('a, unit -> 'b, 'c) t - val pack2 : ('a, 'b -> 'c -> 'd, 'e) t -> ('a, 'b * 'c -> 'd, 'e) t - val pack3 : ('a, 'b -> 'c -> 'd -> 'e, 'f) t -> ('a, 'b * 'c * 'd -> 'e, 'f) t include module type of Ast_pattern_generated @@ -213,37 +225,21 @@ ]} *) val true_ : (bool, 'a, 'a) t - val false_ : (bool, 'a, 'a) t - val eint : (int, 'a, 'b) t -> (expression, 'a, 'b) t - val echar : (char, 'a, 'b) t -> (expression, 'a, 'b) t - val estring : (string, 'a, 'b) t -> (expression, 'a, 'b) t - val efloat : (string, 'a, 'b) t -> (expression, 'a, 'b) t - val eint32 : (int32, 'a, 'b) t -> (expression, 'a, 'b) t - val eint64 : (int64, 'a, 'b) t -> (expression, 'a, 'b) t - val enativeint : (nativeint, 'a, 'b) t -> (expression, 'a, 'b) t - val pint : (int, 'a, 'b) t -> (pattern, 'a, 'b) t - val pchar : (char, 'a, 'b) t -> (pattern, 'a, 'b) t - val pstring : (string, 'a, 'b) t -> (pattern, 'a, 'b) t - val pfloat : (string, 'a, 'b) t -> (pattern, 'a, 'b) t - val pint32 : (int32, 'a, 'b) t -> (pattern, 'a, 'b) t - val pint64 : (int64, 'a, 'b) t -> (pattern, 'a, 'b) t - val pnativeint : (nativeint, 'a, 'b) t -> (pattern, 'a, 'b) t - val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t val no_label : @@ -265,5 +261,4 @@ type context val of_func : (context -> Location.t -> 'a -> 'b -> 'c) -> ('a, 'b, 'c) t - val to_func : ('a, 'b, 'c) t -> context -> Location.t -> 'a -> 'b -> 'c diff -Nru ppxlib-0.24.0/src/ast_traverse.ml ppxlib-0.27.0/src/ast_traverse.ml --- ppxlib-0.24.0/src/ast_traverse.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_traverse.ml 2022-06-14 18:16:33.000000000 +0000 @@ -3,49 +3,41 @@ class map = object inherit Ppxlib_traverse_builtins.map - inherit Ast.map end class iter = object inherit Ppxlib_traverse_builtins.iter - inherit Ast.iter end class ['acc] fold = object inherit ['acc] Ppxlib_traverse_builtins.fold - inherit ['acc] Ast.fold end class ['acc] fold_map = object inherit ['acc] Ppxlib_traverse_builtins.fold_map - inherit ['acc] Ast.fold_map end class ['ctx] map_with_context = object inherit ['ctx] Ppxlib_traverse_builtins.map_with_context - inherit ['ctx] Ast.map_with_context end class virtual ['res] lift = object inherit ['res] Ppxlib_traverse_builtins.lift - inherit ['res] Ast.lift end let module_name = function None -> "_" | Some name -> name - let enter name path = if String.is_empty path then name else path ^ "." ^ name - let enter_opt name_opt path = enter (module_name name_opt) path class map_with_path = @@ -102,8 +94,26 @@ object (self) inherit [Expansion_context.Base.t] map_with_context as super - method! expression ctxt expr = - super#expression (Expansion_context.Base.enter_expr ctxt) expr + method! expression ctxt + { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } = + let ctxt = Expansion_context.Base.enter_expr ctxt in + let pexp_desc = + match pexp_desc with + | Pexp_letmodule (name, module_expr, body) -> + let name = self#loc (self#option self#string) ctxt name in + let module_expr = + self#module_expr + (ec_enter_module_opt ~loc:module_expr.pmod_loc name.txt ctxt) + module_expr + in + let body = self#expression ctxt body in + Pexp_letmodule (name, module_expr, body) + | _ -> self#expression_desc ctxt pexp_desc + in + let pexp_loc = self#location ctxt pexp_loc in + let pexp_loc_stack = self#list self#location ctxt pexp_loc_stack in + let pexp_attributes = self#attributes ctxt pexp_attributes in + { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } method! module_binding ctxt mb = super#module_binding @@ -129,11 +139,10 @@ method! value_binding ctxt { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } = let all_var_names = var_names_of#pattern pvb_pat [] in - let var_name = Stdppx.List.last all_var_names in let in_binding_ctxt = - match var_name with - | None -> ctxt - | Some var_name -> + match all_var_names with + | [] | _ :: _ :: _ -> ctxt + | [ var_name ] -> Expansion_context.Base.enter_value ~loc:pvb_loc var_name ctxt in let pvb_pat = self#pattern ctxt pvb_pat in @@ -146,31 +155,18 @@ class sexp_of = object inherit [Sexp.t] Ast.lift - method int = sexp_of_int - method string = sexp_of_string - method bool = sexp_of_bool - method char = sexp_of_char - method float = sexp_of_float - method int32 = sexp_of_int32 - method int64 = sexp_of_int64 - method nativeint = sexp_of_nativeint - method unit = sexp_of_unit - method option = sexp_of_option - method list = sexp_of_list - method array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t = sexp_of_array - method other : 'a. 'a -> Sexp.t = fun _ -> Sexp.Atom "_" method record fields = diff -Nru ppxlib-0.24.0/src/ast_traverse.mli ppxlib-0.27.0/src/ast_traverse.mli --- ppxlib-0.24.0/src/ast_traverse.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ast_traverse.mli 2022-06-14 18:16:33.000000000 +0000 @@ -30,53 +30,45 @@ class map : object inherit Ppxlib_traverse_builtins.map - inherit Ast.map end class iter : object inherit Ppxlib_traverse_builtins.iter - inherit Ast.iter end class ['acc] fold : object inherit ['acc] Ppxlib_traverse_builtins.fold - inherit ['acc] Ast.fold end class ['acc] fold_map : object inherit ['acc] Ppxlib_traverse_builtins.fold_map - inherit ['acc] Ast.fold_map end class ['ctx] map_with_context : object inherit ['ctx] Ppxlib_traverse_builtins.map_with_context - inherit ['ctx] Ast.map_with_context end class map_with_path : [string] map_with_context - class map_with_expansion_context : [Expansion_context.Base.t] map_with_context class virtual ['res] lift : object inherit ['res] Ppxlib_traverse_builtins.lift - inherit ['res] Ast.lift end class sexp_of : object inherit [Sexp.t] Ppxlib_traverse_builtins.std_lifters - inherit [Sexp.t] Ast.lift end diff -Nru ppxlib-0.24.0/src/attribute.ml ppxlib-0.27.0/src/attribute.ml --- ppxlib-0.24.0/src/attribute.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/attribute.ml 2022-06-14 18:16:33.000000000 +0000 @@ -40,59 +40,32 @@ | Object_type_field : object_field t let label_declaration = Label_declaration - let constructor_declaration = Constructor_declaration - let type_declaration = Type_declaration - let type_extension = Type_extension - let type_exception = Type_exception - let extension_constructor = Extension_constructor - let pattern = Pattern - let core_type = Core_type - let expression = Expression - let value_description = Value_description - let class_type = Class_type - let class_type_field = Class_type_field - let class_infos = Class_infos - let class_expr = Class_expr - let class_field = Class_field - let module_type = Module_type - let module_declaration = Module_declaration - let module_type_declaration = Module_type_declaration - let open_description = Open_description - let include_infos = Include_infos - let module_expr = Module_expr - let value_binding = Value_binding - let module_binding = Module_binding - let pstr_eval = Pstr_eval - let pstr_extension = Pstr_extension - let psig_extension = Psig_extension - let rtag = Rtag - let object_type_field = Object_type_field let get_pstr_eval st = @@ -242,11 +215,8 @@ | Class_type_field : class_type_field t let structure_item = Structure_item - let signature_item = Signature_item - let class_field = Class_field - let class_type_field = Class_type_field let get_attribute_if_is_floating_node : type a. a t -> a -> attribute option = @@ -299,7 +269,6 @@ type packed = T : (_, _) t -> packed let name t = Name.Pattern.name t.name - let context t = t.context let registrar = @@ -323,27 +292,23 @@ type t = string loc let hash : t -> int = Hashtbl.hash - let equal : t -> t -> bool = Poly.equal end) let not_seen = Attribute_table.create 128 - let mark_as_seen { attr_name; _ } = Attribute_table.remove not_seen attr_name - let mark_as_handled_manually = mark_as_seen let explicitly_drop = object inherit Ast_traverse.iter - method! attribute = mark_as_seen end let get_internal = let rec find_best_match t attributes longest_match = match attributes with - | [] -> longest_match + | [] -> Ok longest_match | ({ attr_name = name; _ } as attr) :: rest -> if Name.Pattern.matches t.name name.txt then match longest_match with @@ -353,7 +318,10 @@ let len' = String.length name'.txt in if len > len' then find_best_match t rest (Some attr) else if len < len' then find_best_match t rest longest_match - else Location.raise_errorf ~loc:name.loc "Duplicated attribute" + else + Error + ( Location.Error.createf ~loc:name.loc "Duplicated attribute", + [] ) else find_best_match t rest longest_match in fun t attributes -> find_best_match t attributes None @@ -361,55 +329,81 @@ let convert ?(do_mark_as_seen = true) pattern attr = if do_mark_as_seen then mark_as_seen attr; let (Payload_parser (pattern, k)) = pattern in - Ast_pattern.parse pattern + Ast_pattern.parse_res pattern (Common.loc_of_payload attr) attr.attr_payload (k ~name_loc:attr.attr_name.loc) -let get t ?mark_as_seen:do_mark_as_seen x = +let get_res t ?mark_as_seen:do_mark_as_seen x = + let open Result in let attrs = Context.get_attributes t.context x in - match get_internal t attrs with - | None -> None - | Some attr -> Some (convert t.payload attr ?do_mark_as_seen) + get_internal t attrs >>= fun res -> + match res with + | None -> Ok None + | Some attr -> + convert t.payload attr ?do_mark_as_seen >>| fun value -> Some value -let consume t x = +let get t ?mark_as_seen:do_mark_as_seen x = + get_res t ?mark_as_seen:do_mark_as_seen x + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let consume_res t x = + let open Result in let attrs = Context.get_attributes t.context x in - match get_internal t attrs with - | None -> None + get_internal t attrs >>= fun res -> + match res with + | None -> Ok None | Some attr -> let attrs = List.filter attrs ~f:(fun attr' -> not (attr == attr')) in let x = Context.set_attributes t.context x attrs in - Some (x, convert t.payload attr) + convert t.payload attr >>| fun value -> Some (x, value) -let remove_seen (type a) (context : a Context.t) packeds (x : a) = +let consume t x = + consume_res t x + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let remove_seen_res (type a) (context : a Context.t) packeds (x : a) = + let open Result in let attrs = Context.get_attributes context x in - let matched = - let rec loop acc = function - | [] -> acc - | T t :: rest -> - if Context.equal t.context context then - match get_internal t attrs with - | None -> loop acc rest - | Some attr -> - let name = attr.attr_name in - if Attribute_table.mem not_seen name then loop acc rest - else loop (attr :: acc) rest - else loop acc rest - in - loop [] packeds + let rec loop acc = function + | [] -> Ok acc + | T t :: rest -> + if Context.equal t.context context then + get_internal t attrs >>= fun res -> + match res with + | None -> loop acc rest + | Some attr -> + let name = attr.attr_name in + if Attribute_table.mem not_seen name then loop acc rest + else loop (attr :: acc) rest + else loop acc rest in + loop [] packeds >>| fun matched -> let attrs = List.filter attrs ~f:(fun attr' -> not (List.memq ~set:matched attr')) in Context.set_attributes context x attrs -let pattern t p = +let remove_seen (type a) (context : a Context.t) packeds (x : a) = + remove_seen_res (context : a Context.t) packeds (x : a) + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let pattern_res t p = + let open Result in let f = Ast_pattern.to_func p in Ast_pattern.of_func (fun ctx loc x k -> - match consume t x with + consume_res t x >>| fun res -> + match res with | None -> f ctx loc x (k None) | Some (x, v) -> f ctx loc x (k (Some v))) +let pattern t p = + pattern_res t p |> Ast_pattern.to_func + |> (fun f a b c d -> + f a b c d + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err)) + |> Ast_pattern.of_func + module Floating = struct module Context = Floating_context @@ -429,9 +423,10 @@ payload = Payload_parser (pattern, fun ~name_loc:_ -> k); } - let convert ts x = + let convert_res ts x = + let open Result in match ts with - | [] -> None + | [] -> Ok None | { context; _ } :: _ -> ( assert (List.for_all ts ~f:(fun t -> Context.equal t.context context)); let attr = Context.get_attribute context x in @@ -439,34 +434,233 @@ match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name.txt) with - | [] -> None - | [ t ] -> Some (convert t.payload attr) + | [] -> Ok None + | [ t ] -> convert t.payload attr >>| fun value -> Some value | l -> - Location.raise_errorf ~loc:name.loc - "Multiple match for floating attributes: %s" - (String.concat ~sep:", " - (List.map l ~f:(fun t -> Name.Pattern.name t.name)))) + Error + ( Location.Error.createf ~loc:name.loc + "Multiple match for floating attributes: %s" + (String.concat ~sep:", " + (List.map l ~f:(fun t -> Name.Pattern.name t.name))), + [] )) + + let convert ts x = + convert_res ts x + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) end -let check_attribute registrar context name = +let collect_attribute_errors registrar context name = if (not - (Name.Whitelisted.is_whitelisted ~kind:`Attribute name.txt + (Name.Allowlisted.is_allowlisted ~kind:`Attribute name.txt || Name.ignore_checks name.txt)) && Attribute_table.mem not_seen name then - let white_list = Name.Whitelisted.get_attribute_list () in - Name.Registrar.raise_errorf registrar context ~white_list - "Attribute `%s' was not used" name + let allowlist = Name.Allowlisted.get_attribute_list () in + [ + Name.Registrar.Error.createf registrar context ~allowlist + "Attribute `%s' was not used" name; + ] + else [] + +let collect_unused_attributes_errors = + object (self) + inherit [Location.Error.t list] Ast_traverse.fold as super + + method! attribute { attr_name = name; _ } _ = + [ + Location.Error.createf ~loc:name.loc + "attribute not expected here, Ppxlib.Attribute needs updating!"; + ] + + method private check_node : type a. + a Context.t -> a -> a * Location.Error.t list = + fun context node -> + let attrs = Context.get_attributes context node in + match attrs with + | [] -> (node, []) + | _ -> + let errors = + List.map attrs + ~f:(fun + ({ attr_name = name; attr_payload = payload; _ } as attr) + -> + let collected_errors = + self#payload payload [] + @ collect_attribute_errors registrar (On_item context) name + in + (* If we allow the attribute to pass through, mark it as seen *) + mark_as_seen attr; + collected_errors) + |> List.concat + in + (Context.set_attributes context node [], errors) + + method private check_floating : type a. + a Floating.Context.t -> a -> a * Location.Error.t list = + fun context node -> + match + Floating.Context.get_attribute_if_is_floating_node context node + with + | None -> (node, []) + | Some ({ attr_name = name; attr_payload = payload; _ } as attr) -> + let collected_errors = + self#payload payload [] + @ collect_attribute_errors registrar (Floating context) name + in + mark_as_seen attr; + (Floating.Context.replace_by_dummy context node, collected_errors) + + method! label_declaration x acc = + let res, errors = self#check_node Label_declaration x in + super#label_declaration res (acc @ errors) + + method! constructor_declaration x acc = + let res, errors = self#check_node Constructor_declaration x in + super#constructor_declaration res (acc @ errors) + + method! type_declaration x acc = + let res, errors = self#check_node Type_declaration x in + super#type_declaration res (acc @ errors) + + method! type_extension x acc = + let res, errors = self#check_node Type_extension x in + super#type_extension res (acc @ errors) + + method! type_exception x acc = + let res, errors = self#check_node Type_exception x in + super#type_exception res (acc @ errors) + + method! extension_constructor x acc = + let res, errors = self#check_node Extension_constructor x in + super#extension_constructor res (acc @ errors) + + method! pattern x acc = + let res, errors = self#check_node Pattern x in + super#pattern res (acc @ errors) + + method! core_type x acc = + let res, errors = self#check_node Core_type x in + super#core_type res (acc @ errors) + + method! expression x acc = + let res, errors = self#check_node Expression x in + super#expression res (acc @ errors) + + method! value_description x acc = + let res, errors = self#check_node Value_description x in + super#value_description res (acc @ errors) + + method! class_type x acc = + let res, errors = self#check_node Class_type x in + super#class_type res (acc @ errors) + + method! class_infos f x acc = + let res, errors = self#check_node Class_infos x in + super#class_infos f res (acc @ errors) + + method! class_expr x acc = + let res, errors = self#check_node Class_expr x in + super#class_expr res (acc @ errors) + + method! module_type x acc = + let res, errors = self#check_node Module_type x in + super#module_type res (acc @ errors) + + method! module_declaration x acc = + let res, errors = self#check_node Module_declaration x in + super#module_declaration res (acc @ errors) + + method! module_type_declaration x acc = + let res, errors = self#check_node Module_type_declaration x in + super#module_type_declaration res (acc @ errors) + + method! open_description x acc = + let res, errors = self#check_node Open_description x in + super#open_description res (acc @ errors) + + method! open_declaration x acc = + let res, errors = self#check_node Open_declaration x in + super#open_declaration res (acc @ errors) + + method! include_infos f x acc = + let res, errors = self#check_node Include_infos x in + super#include_infos f res (acc @ errors) + + method! module_expr x acc = + let res, errors = self#check_node Module_expr x in + super#module_expr res (acc @ errors) + + method! value_binding x acc = + let res, errors = self#check_node Value_binding x in + super#value_binding res (acc @ errors) + + method! module_binding x acc = + let res, errors = self#check_node Module_binding x in + super#module_binding res (acc @ errors) + + method! class_field x acc = + let x, errors1 = self#check_node Class_field x in + let x, errors2 = self#check_floating Class_field x in + super#class_field x (acc @ errors1 @ errors2) + + method! class_type_field x acc = + let x, errors1 = self#check_node Class_type_field x in + let x, errors2 = self#check_floating Class_type_field x in + super#class_type_field x (acc @ errors1 @ errors2) + + method! row_field x acc = + let x, errors = + match x.prf_desc with Rtag _ -> self#check_node Rtag x | _ -> (x, []) + in + super#row_field x (acc @ errors) + + method! core_type_desc x acc = + let x, errors = + match x with + | Ptyp_object (fields, closed_flag) -> + let fields, errors = + List.map fields ~f:(self#check_node Object_type_field) + |> List.split + in + (Ptyp_object (fields, closed_flag), List.concat errors) + | _ -> (x, []) + in + super#core_type_desc x (acc @ errors) + + method! structure_item item acc = + let item, errors = self#check_floating Structure_item item in + let item, errors2 = + match item.pstr_desc with + | Pstr_eval _ -> self#check_node Pstr_eval item + | Pstr_extension _ -> self#check_node Pstr_extension item + | _ -> (item, []) + in + super#structure_item item (acc @ errors @ errors2) + + method! signature_item item acc = + let item, errors = self#check_floating Signature_item item in + let item, errors2 = + match item.psig_desc with + | Psig_extension _ -> self#check_node Psig_extension item + | _ -> (item, []) + in + super#signature_item item (acc @ errors @ errors2) + end + +let check_attribute registrar context name = + match collect_attribute_errors registrar context name with + | [] -> () + | err :: _ -> Location.Error.raise err + +let raise_if_non_empty = function + | [] -> () + | err :: _ -> Location.Error.raise err let check_unused = object (self) inherit Ast_traverse.iter as super - method! attribute { attr_name = name; _ } = - Location.raise_errorf ~loc:name.loc - "attribute not expected here, Ppxlib.Attribute needs updating!" - method private check_node : type a. a Context.t -> a -> a = fun context node -> let attrs = Context.get_attributes context node in @@ -482,123 +676,105 @@ mark_as_seen attr); Context.set_attributes context node [] - method private check_floating : type a. a Floating.Context.t -> a -> a = - fun context node -> - match - Floating.Context.get_attribute_if_is_floating_node context node - with - | None -> node - | Some ({ attr_name = name; attr_payload = payload; _ } as attr) -> - self#payload payload; - check_attribute registrar (Floating context) name; - mark_as_seen attr; - Floating.Context.replace_by_dummy context node + method! attribute { attr_name = name; _ } = + Location.raise_errorf ~loc:name.loc + "attribute not expected here, Ppxlib.Attribute needs updating!" method! label_declaration x = - super#label_declaration (self#check_node Label_declaration x) + collect_unused_attributes_errors#label_declaration x [] + |> raise_if_non_empty method! constructor_declaration x = - super#constructor_declaration (self#check_node Constructor_declaration x) + collect_unused_attributes_errors#constructor_declaration x [] + |> raise_if_non_empty method! type_declaration x = - super#type_declaration (self#check_node Type_declaration x) + collect_unused_attributes_errors#type_declaration x [] + |> raise_if_non_empty method! type_extension x = - super#type_extension (self#check_node Type_extension x) + collect_unused_attributes_errors#type_extension x [] |> raise_if_non_empty method! type_exception x = - super#type_exception (self#check_node Type_exception x) + collect_unused_attributes_errors#type_exception x [] |> raise_if_non_empty method! extension_constructor x = - super#extension_constructor (self#check_node Extension_constructor x) + collect_unused_attributes_errors#extension_constructor x [] + |> raise_if_non_empty - method! pattern x = super#pattern (self#check_node Pattern x) + method! pattern x = + collect_unused_attributes_errors#pattern x [] |> raise_if_non_empty - method! core_type x = super#core_type (self#check_node Core_type x) + method! core_type x = + collect_unused_attributes_errors#core_type x [] |> raise_if_non_empty - method! expression x = super#expression (self#check_node Expression x) + method! expression x = + collect_unused_attributes_errors#expression x [] |> raise_if_non_empty method! value_description x = - super#value_description (self#check_node Value_description x) + collect_unused_attributes_errors#value_description x [] + |> raise_if_non_empty - method! class_type x = super#class_type (self#check_node Class_type x) + method! class_type x = + collect_unused_attributes_errors#class_type x [] |> raise_if_non_empty method! class_infos f x = super#class_infos f (self#check_node Class_infos x) - method! class_expr x = super#class_expr (self#check_node Class_expr x) + method! class_expr x = + collect_unused_attributes_errors#class_expr x [] |> raise_if_non_empty - method! module_type x = super#module_type (self#check_node Module_type x) + method! module_type x = + collect_unused_attributes_errors#module_type x [] |> raise_if_non_empty method! module_declaration x = - super#module_declaration (self#check_node Module_declaration x) + collect_unused_attributes_errors#module_declaration x [] + |> raise_if_non_empty method! module_type_declaration x = - super#module_type_declaration (self#check_node Module_type_declaration x) + collect_unused_attributes_errors#module_type_declaration x [] + |> raise_if_non_empty method! open_description x = - super#open_description (self#check_node Open_description x) + collect_unused_attributes_errors#open_description x [] + |> raise_if_non_empty method! open_declaration x = - super#open_declaration (self#check_node Open_declaration x) + collect_unused_attributes_errors#open_declaration x [] + |> raise_if_non_empty method! include_infos f x = super#include_infos f (self#check_node Include_infos x) - method! module_expr x = super#module_expr (self#check_node Module_expr x) + method! module_expr x = + collect_unused_attributes_errors#module_expr x [] |> raise_if_non_empty method! value_binding x = - super#value_binding (self#check_node Value_binding x) + collect_unused_attributes_errors#value_binding x [] |> raise_if_non_empty method! module_binding x = - super#module_binding (self#check_node Module_binding x) + collect_unused_attributes_errors#module_binding x [] |> raise_if_non_empty method! class_field x = - let x = self#check_node Class_field x in - let x = self#check_floating Class_field x in - super#class_field x + collect_unused_attributes_errors#class_field x [] |> raise_if_non_empty method! class_type_field x = - let x = self#check_node Class_type_field x in - let x = self#check_floating Class_type_field x in - super#class_type_field x + collect_unused_attributes_errors#class_type_field x [] + |> raise_if_non_empty method! row_field x = - let x = - match x.prf_desc with Rtag _ -> self#check_node Rtag x | _ -> x - in - super#row_field x + collect_unused_attributes_errors#row_field x [] |> raise_if_non_empty method! core_type_desc x = - let x = - match x with - | Ptyp_object (fields, closed_flag) -> - let fields = - List.map fields ~f:(self#check_node Object_type_field) - in - Ptyp_object (fields, closed_flag) - | _ -> x - in - super#core_type_desc x + collect_unused_attributes_errors#core_type_desc x [] |> raise_if_non_empty method! structure_item item = - let item = self#check_floating Structure_item item in - let item = - match item.pstr_desc with - | Pstr_eval _ -> self#check_node Pstr_eval item - | Pstr_extension _ -> self#check_node Pstr_extension item - | _ -> item - in - super#structure_item item + collect_unused_attributes_errors#structure_item item [] + |> raise_if_non_empty method! signature_item item = - let item = self#check_floating Signature_item item in - let item = - match item.psig_desc with - | Psig_extension _ -> self#check_node Psig_extension item - | _ -> item - in - super#signature_item item + collect_unused_attributes_errors#signature_item item [] + |> raise_if_non_empty end let reset_checks () = Attribute_table.clear not_seen @@ -614,13 +790,20 @@ Attribute_table.add not_seen name loc end -let check_all_seen () = - let fail name loc = +let collect_unseen_errors () = + let fail name loc acc = let txt = name.txt in if not (Name.ignore_checks txt) then - Location.raise_errorf ~loc "Attribute `%s' was silently dropped" txt + Location.Error.createf ~loc "Attribute `%s' was silently dropped" txt + :: acc + else acc in - Attribute_table.iter fail not_seen + Attribute_table.fold fail not_seen [] + +let check_all_seen () = + match collect_unseen_errors () with + | [] -> () + | err :: _ -> Location.Error.raise err let remove_attributes_present_in table = object diff -Nru ppxlib-0.24.0/src/attribute.mli ppxlib-0.27.0/src/attribute.mli --- ppxlib-0.24.0/src/attribute.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/attribute.mli 2022-06-14 18:16:33.000000000 +0000 @@ -48,59 +48,32 @@ | Object_type_field : object_field t val label_declaration : label_declaration t - val constructor_declaration : constructor_declaration t - val type_declaration : type_declaration t - val type_extension : type_extension t - val type_exception : type_exception t - val extension_constructor : extension_constructor t - val pattern : pattern t - val core_type : core_type t - val expression : expression t - val value_description : value_description t - val class_type : class_type t - val class_type_field : class_type_field t - val class_infos : _ class_infos t - val class_expr : class_expr t - val class_field : class_field t - val module_type : module_type t - val module_declaration : module_declaration t - val module_type_declaration : module_type_declaration t - val open_description : open_description t - val include_infos : _ include_infos t - val module_expr : module_expr t - val value_binding : value_binding t - val module_binding : module_binding t - val pstr_eval : structure_item t - val pstr_extension : structure_item t - val psig_extension : signature_item t - val rtag : row_field t - val object_type_field : object_field t end @@ -155,22 +128,39 @@ attribute. *) val name : _ t -> string - val context : ('a, _) t -> 'a Context.t +val get_res : + ('a, 'b) t -> + ?mark_as_seen:bool (** default [true] *) -> + 'a -> + ('b option, Location.Error.t NonEmptyList.t) result +(** Gets the associated attribute value. Marks the attribute as seen unless + [mark_as_seen=false]. Returns an [Error] if the attribute is duplicated *) + val get : ('a, 'b) t -> ?mark_as_seen:bool (** default [true] *) -> 'a -> 'b option -(** Gets the associated attribute value. Marks the attribute as seen unless - [mark_as_seen=false]. *) +(** See {!get_res}. Raises a located error if the attribute is duplicated *) -val consume : ('a, 'b) t -> 'a -> ('a * 'b) option -(** [consume t x] returns the value associated to attribute [t] on [x] if +val consume_res : + ('a, 'b) t -> 'a -> (('a * 'b) option, Location.Error.t NonEmptyList.t) result +(** [consume_res t x] returns the value associated to attribute [t] on [x] if present as well as [x] with [t] removed. *) -val remove_seen : 'a Context.t -> packed list -> 'a -> 'a +val consume : ('a, 'b) t -> 'a -> ('a * 'b) option +(** See {!consume_res}. Raises a located exception in case of error. *) + +val remove_seen_res : + 'a Context.t -> + packed list -> + 'a -> + ('a, Location.Error.t NonEmptyList.t) result (** [remove_seen x attrs] removes the set of attributes matched by elements of [attrs]. Only remove them if they where seen by {!get} or {!consume}. *) +val remove_seen : 'a Context.t -> packed list -> 'a -> 'a +(** See {!remove_seen_res}. Raises in case of error. *) + module Floating : sig type ('context, 'payload) t @@ -182,11 +172,8 @@ | Class_type_field : class_type_field t val structure_item : structure_item t - val signature_item : signature_item t - val class_field : class_field t - val class_type_field : class_type_field t end @@ -199,6 +186,9 @@ val name : _ t -> string + val convert_res : + ('a, 'b) t list -> 'a -> ('b option, Location.Error.t NonEmptyList.t) result + val convert : ('a, 'b) t list -> 'a -> 'b option end @@ -207,17 +197,22 @@ object. All attributes inside will be marked as handled. *) val check_unused : Ast_traverse.iter -(** Raise if there are unused attributes *) +(** Raise if there are unused attributes. *) + +val collect_unused_attributes_errors : Location.Error.t list Ast_traverse.fold +(** Collect all errors due to unused attributes. *) val collect : Ast_traverse.iter (** Collect all attribute names. To be used in conjunction with {!check_all_seen}. *) +val collect_unseen_errors : unit -> Location.Error.t list + val check_all_seen : unit -> unit (** Check that all attributes collected by {!freshen_and_collect} have been: - matched at least once by one of: {!get}, {!consume} or {!Floating.convert} - - seen by [check_unused] (to allow white-listed attributed to pass through) + - seen by [check_unused] (to allow allowlisted attributed to pass through) This helps with faulty ppx rewriters that silently drop attributes. *) @@ -231,10 +226,17 @@ debug extensions that drop attributes. *) val dropped_so_far_signature : signature -> string Loc.t list - val reset_checks : unit -> unit val pattern : ('a, 'b) t -> ('a, 'c, 'd) Ast_pattern.t -> ('a, 'b option -> 'c, 'd) Ast_pattern.t + +val pattern_res : + ('a, 'b) t -> + ('a, 'c, 'd) Ast_pattern.t -> + ( 'a, + 'b option -> 'c, + ('d, Location.Error.t NonEmptyList.t) result ) + Ast_pattern.t diff -Nru ppxlib-0.24.0/src/code_matcher.ml ppxlib-0.27.0/src/code_matcher.ml --- ppxlib-0.24.0/src/code_matcher.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/code_matcher.ml 2022-06-14 18:16:33.000000000 +0000 @@ -22,7 +22,6 @@ type t val get_loc : t -> Location.t - val end_marker : (t, unit) Attribute.Floating.t module Transform (T : T1) : sig @@ -34,9 +33,7 @@ end val parse : Lexing.lexbuf -> t list - val pp : Format.formatter -> t -> unit - val to_sexp : t -> Sexp.t end) = struct @@ -46,12 +43,15 @@ let loc = { Location.loc_start = pos; loc_end = pos; loc_ghost = false } in - Location.raise_errorf ~loc "ppxlib: [@@@@@@%s] attribute missing" - (Attribute.Floating.name M.end_marker) + Error + ( Location.Error.createf ~loc "ppxlib: [@@@@@@%s] attribute missing" + (Attribute.Floating.name M.end_marker), + [] ) | x :: l -> ( - match Attribute.Floating.convert [ M.end_marker ] x with - | None -> loop (x :: acc) l - | Some () -> (List.rev acc, (M.get_loc x).loc_start) + match Attribute.Floating.convert_res [ M.end_marker ] x with + | Ok None -> loop (x :: acc) l + | Ok (Some ()) -> Ok (List.rev acc, (M.get_loc x).loc_start) + | Error e -> Error e | exception Failure _ -> loop (x :: acc) l) in loop [] l @@ -59,9 +59,7 @@ let remove_loc = object inherit Ast_traverse.map - method! location _ = Location.none - method! location_stack _ = [] end @@ -70,7 +68,6 @@ end) let remove_loc x = M_map.apply remove_loc x - let rec last prev = function [] -> prev | x :: l -> last x l let diff_asts ~generated ~round_trip = @@ -144,7 +141,8 @@ match_loop ~end_pos ~mismatch_handler ~expected ~source let do_match ~pos ~expected ~mismatch_handler source = - let source, end_pos = extract_prefix ~pos source in + let open Result in + extract_prefix ~pos source >>| fun (source, end_pos) -> match_loop ~end_pos ~mismatch_handler ~expected ~source end @@ -153,7 +151,6 @@ type t = structure_item let get_loc x = x.pstr_loc - let end_marker = end_marker_str module Transform (T : T1) = struct @@ -161,9 +158,7 @@ end let parse = Parse.implementation - let pp = Pprintast.structure_item - let to_sexp = Ast_traverse.sexp_of#structure_item end) @@ -172,7 +167,6 @@ type t = signature_item let get_loc x = x.psig_loc - let end_marker = end_marker_sig module Transform (T : T1) = struct @@ -180,14 +174,20 @@ end let parse = Parse.interface - let pp = Pprintast.signature_item - let to_sexp = Ast_traverse.sexp_of#signature_item end) (*$*) -let match_structure = Str.do_match +let match_structure_res = Str.do_match + +let match_structure ~pos ~expected ~mismatch_handler l = + match_structure_res ~pos ~expected ~mismatch_handler l + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let match_signature_res = Sig.do_match -let match_signature = Sig.do_match +let match_signature ~pos ~expected ~mismatch_handler l = + match_signature_res ~pos ~expected ~mismatch_handler l + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) diff -Nru ppxlib-0.24.0/src/code_matcher.mli ppxlib-0.27.0/src/code_matcher.mli --- ppxlib-0.24.0/src/code_matcher.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/code_matcher.mli 2022-06-14 18:16:33.000000000 +0000 @@ -2,20 +2,36 @@ open! Import -val match_structure : +val match_structure_res : pos:Lexing.position -> expected:structure -> mismatch_handler:(Location.t -> structure -> unit) -> structure -> - unit + (unit, Location.Error.t NonEmptyList.t) result (** Checks that the given code starts with [expected] followed by [@@@deriving.end] or [@@@end]. - Raises if there is no [@@@deriving.end]. + Returns an error if there is no [@@@deriving.end]. If some items don't match, it calls [mismatch_handler] with the location of the source items and the expected code. *) +val match_structure : + pos:Lexing.position -> + expected:structure -> + mismatch_handler:(Location.t -> structure -> unit) -> + structure -> + unit +(** See {!match_structure_res}. Raises a located error in case of error. *) + +val match_signature_res : + pos:Lexing.position -> + expected:signature -> + mismatch_handler:(Location.t -> signature -> unit) -> + signature -> + (unit, Location.Error.t NonEmptyList.t) result +(** Same for signatures *) + val match_signature : pos:Lexing.position -> expected:signature -> diff -Nru ppxlib-0.24.0/src/code_path.ml ppxlib-0.27.0/src/code_path.ml --- ppxlib-0.24.0/src/code_path.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/code_path.ml 2022-06-14 18:16:33.000000000 +0000 @@ -4,6 +4,8 @@ file_path : string; main_module_name : string; submodule_path : string loc list; + enclosing_module : string; + enclosing_value : string option; value : string loc option; in_expr : bool; } @@ -17,13 +19,16 @@ file_path; main_module_name; submodule_path = []; + enclosing_module = main_module_name; + enclosing_value = None; value = None; in_expr = false; } let file_path t = t.file_path - let main_module_name t = t.main_module_name +let enclosing_module t = t.enclosing_module +let enclosing_value t = t.enclosing_value let submodule_path t = List.rev_map ~f:(fun located -> located.txt) t.submodule_path @@ -41,15 +46,24 @@ let enter_expr t = { t with in_expr = true } let enter_module ~loc module_name t = - if t.in_expr then t + if t.in_expr then { t with enclosing_module = module_name } else - { t with submodule_path = { txt = module_name; loc } :: t.submodule_path } + { + t with + submodule_path = { txt = module_name; loc } :: t.submodule_path; + enclosing_module = module_name; + } let enter_value ~loc value_name t = - if t.in_expr then t else { t with value = Some { txt = value_name; loc } } + if t.in_expr then { t with enclosing_value = Some value_name } + else + { + t with + value = Some { txt = value_name; loc }; + enclosing_value = Some value_name; + } let to_string_path t = String.concat ~sep:"." (t.file_path :: submodule_path t) - let with_string_path f ~loc ~path = f ~loc ~path:(to_string_path path);; let module M = struct diff -Nru ppxlib-0.24.0/src/code_path.mli ppxlib-0.27.0/src/code_path.mli --- ppxlib-0.24.0/src/code_path.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/code_path.mli 2022-06-14 18:16:33.000000000 +0000 @@ -14,10 +14,18 @@ (** Return the path within the main module this code path represents as a list of module names. *) +val enclosing_module : t -> string +(** Return the nearest enclosing module name. Does descend into expressions. *) + val value : t -> string option (** Return the name of the value to which this code path leads or [None] if it leads to the toplevel of a module or submodule. *) +val enclosing_value : t -> string option +(** Like [value], returns the name of an enclosing value definition. Unlike + [value], includes names inside expressions, not just names that the code + path can reach from the toplevel module. *) + val fully_qualified_path : t -> string (** Return the fully qualified path to the module or value this code path leads to, eg ["Some_main_module.Some_submodule.some_value"]. Note that the fully diff -Nru ppxlib-0.24.0/src/common.ml ppxlib-0.27.0/src/common.ml --- ppxlib-0.24.0/src/common.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/common.ml 2022-06-14 18:16:33.000000000 +0000 @@ -37,21 +37,33 @@ let prefix = strip_gen_symbol_suffix prefix in Printf.sprintf "%s__%03i_" prefix !cnt -let name_type_params_in_td (td : type_declaration) : type_declaration = +let name_type_params_in_td_res (td : type_declaration) : + (type_declaration, _) result = + let open Result in let prefix_string i = (* a, b, ..., y, z, aa, bb, ... *) String.make ((i / 26) + 1) (Char.chr (Char.code 'a' + (i mod 26))) in let name_param i (tp, variance) = - let ptyp_desc = - match tp.ptyp_desc with - | Ptyp_any -> Ptyp_var (gen_symbol ~prefix:(prefix_string i) ()) - | Ptyp_var _ as v -> v - | _ -> Location.raise_errorf ~loc:tp.ptyp_loc "not a type parameter" - in - ({ tp with ptyp_desc }, variance) + (match tp.ptyp_desc with + | Ptyp_any -> Ok (Ptyp_var (gen_symbol ~prefix:(prefix_string i) ())) + | Ptyp_var _ as v -> Ok v + | _ -> + Error (Location.Error.createf ~loc:tp.ptyp_loc "not a type parameter")) + >>| fun ptyp_desc -> ({ tp with ptyp_desc }, variance) + in + let ptype_params, errors = + td.ptype_params |> List.mapi ~f:name_param + |> List.partition_map (function + | Ok o -> Either.Left o + | Error e -> Either.Right e) in - { td with ptype_params = List.mapi td.ptype_params ~f:name_param } + match errors with [] -> Ok { td with ptype_params } | t :: q -> Error (t, q) + +let name_type_params_in_td (td : type_declaration) : type_declaration = + match name_type_params_in_td_res td with + | Ok res -> res + | Error (err, _) -> Location.Error.raise err let combinator_type_of_type_declaration td ~f = let td = name_type_params_in_td td in @@ -70,20 +82,23 @@ Format.pp_print_flush ppf (); Buffer.contents buf -let get_type_param_name (ty, _) = +let get_type_param_name_res (ty, _) = let loc = ty.ptyp_loc in match ty.ptyp_desc with - | Ptyp_var name -> Located.mk ~loc name - | _ -> Location.raise_errorf ~loc "not a type parameter" + | Ptyp_var name -> Ok (Located.mk ~loc name) + | _ -> Error (Location.Error.createf ~loc "not a type parameter", []) + +let get_type_param_name t = + match get_type_param_name_res t with + | Ok e -> e + | Error (err, _) -> Location.Error.raise err exception Type_is_recursive class type_is_recursive rec_flag tds = object (self) inherit Ast_traverse.iter as super - val type_names : string list = List.map tds ~f:(fun td -> td.ptype_name.txt) - method return_true () = raise_notrace Type_is_recursive method! core_type ctype = @@ -113,7 +128,6 @@ end let really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go () - let rec last x l = match l with [] -> x | x :: l -> last x l let loc_of_name_and_payload name payload = @@ -160,19 +174,29 @@ loop (List.rev orig_forward_args) | _ -> expr -let rec assert_no_attributes = function +let attributes_errors = + List.filter_map ~f:(function + | { attr_name = name; attr_loc = _; attr_payload = _ } + when Name.ignore_checks name.Location.txt -> + None + | attr -> + let loc = loc_of_attribute attr in + Some (Location.Error.createf ~loc "Attributes not allowed here")) + +let collect_attributes_errors = + object + inherit [Location.Error.t list] Ast_traverse.fold + method! attribute a acc = attributes_errors [ a ] @ acc + end + +let assert_no_attributes l = + match attributes_errors l with | [] -> () - | { attr_name = name; attr_loc = _; attr_payload = _ } :: rest - when Name.ignore_checks name.Location.txt -> - assert_no_attributes rest - | attr :: _ -> - let loc = loc_of_attribute attr in - Location.raise_errorf ~loc "Attributes not allowed here" + | err :: _ -> Location.Error.raise err let assert_no_attributes_in = object inherit Ast_traverse.iter - method! attribute a = assert_no_attributes [ a ] end diff -Nru ppxlib-0.24.0/src/common.mli ppxlib-0.27.0/src/common.mli --- ppxlib-0.24.0/src/common.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/common.mli 2022-06-14 18:16:33.000000000 +0000 @@ -1,9 +1,11 @@ open! Import val lident : string -> Longident.t - val core_type_of_type_declaration : type_declaration -> core_type +val name_type_params_in_td_res : + type_declaration -> (type_declaration, Location.Error.t NonEmptyList.t) result + val name_type_params_in_td : type_declaration -> type_declaration val combinator_type_of_type_declaration : @@ -15,14 +17,19 @@ @param prefix default = "_x" *) val string_of_core_type : core_type -> string - val assert_no_attributes : attributes -> unit - val assert_no_attributes_in : Ast_traverse.iter +val attributes_errors : attributes -> Location.Error.t list +val collect_attributes_errors : Location.Error.t list Ast_traverse.fold + +val get_type_param_name_res : + core_type * (variance * injectivity) -> + (string Loc.t, Location.Error.t NonEmptyList.t) result +(** [get_type_param_name_res tp] returns the string identifier associated with + [tp] if it is a type parameter, as a result. *) val get_type_param_name : core_type * (variance * injectivity) -> string Loc.t -(** [get_tparam_id tp] returns the string identifier associated with [tp] if it - is a type parameter. *) +(** See {!get_type_param_name_res}. Raises a located error in case of failure. *) (** [(new type_is_recursive rec_flag tds)#go ()] returns whether [rec_flag, tds] is really a recursive type. We disregard recursive occurrences appearing in @@ -33,11 +40,8 @@ -> type_declaration list -> object inherit Ast_traverse.iter - val type_names : string list - method return_true : unit -> unit - method go : unit -> rec_flag end @@ -45,9 +49,7 @@ (** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()] *) val loc_of_payload : attribute -> Location.t - val loc_of_attribute : attribute -> Location.t - val loc_of_extension : extension -> Location.t val curry_applications : expression -> expression diff -Nru ppxlib-0.24.0/src/context_free.ml ppxlib-0.27.0/src/context_free.ml --- ppxlib-0.24.0/src/context_free.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/context_free.ml 2022-06-14 18:16:33.000000000 +0000 @@ -188,7 +188,6 @@ } let nop = { f = (fun _ _ _ -> ()) } - let replace t context loc x = t.f context loc x let insert_after t context (loc : Location.t) x = @@ -198,34 +197,43 @@ end let rec map_node_rec context ts super_call loc base_ctxt x = + let open Result in let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in match EC.get_extension context x with - | None -> super_call base_ctxt x + | None -> Ok (super_call base_ctxt x) | Some (ext, attrs) -> ( - match E.For_context.convert ts ~ctxt ext with - | None -> super_call base_ctxt x + E.For_context.convert_res ts ~ctxt ext >>= fun converted -> + match converted with + | None -> Ok (super_call base_ctxt x) | Some x -> - map_node_rec context ts super_call loc base_ctxt - (EC.merge_attributes context x attrs)) + EC.merge_attributes_res context x attrs >>= fun x -> + map_node_rec context ts super_call loc base_ctxt x) let map_node context ts super_call loc base_ctxt x ~hook = + let open Result in let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in - match EC.get_extension context x with - | None -> super_call base_ctxt x - | Some (ext, attrs) -> ( - match E.For_context.convert ts ~ctxt ext with - | None -> super_call base_ctxt x - | Some x -> - let generated_code = + let res = + match EC.get_extension context x with + | None -> Ok (super_call base_ctxt x) + | Some (ext, attrs) -> ( + E.For_context.convert_res ts ~ctxt ext >>= fun converted -> + match converted with + | None -> Ok (super_call base_ctxt x) + | Some x -> map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) - in - Generated_code_hook.replace hook context loc (Single generated_code); - generated_code) + >>| fun generated_code -> + Generated_code_hook.replace hook context loc (Single generated_code); + generated_code) + in + match res with + | Ok e -> e + | Error (hd_err, _) -> + EC.node_of_extension context ~x (Location.Error.to_extension hd_err) let rec map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code = @@ -248,26 +256,36 @@ Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline ts ~ctxt ext with - | None -> + match E.For_context.convert_inline_res ts ~ctxt ext with + | Ok None -> let x = super_call base_ctxt x in let l = map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code in x :: l - | Some x -> - assert_no_attributes attrs; - let generated_code = - map_nodes context ts super_call get_loc base_ctxt x ~hook - ~in_generated_code:true - in - if not in_generated_code then - Generated_code_hook.replace hook context extension_point_loc - (Many generated_code); - generated_code - @ map_nodes context ts super_call get_loc base_ctxt l ~hook - ~in_generated_code)) + | Ok (Some converted) -> + let attributes_errors = attributes_errors attrs in + if List.length attributes_errors = 0 then ( + let generated_code = + map_nodes context ts super_call get_loc base_ctxt converted + ~hook ~in_generated_code:true + in + if not in_generated_code then + Generated_code_hook.replace hook context extension_point_loc + (Many generated_code); + generated_code + @ map_nodes context ts super_call get_loc base_ctxt l ~hook + ~in_generated_code) + else + attributes_errors + |> List.map ~f:Location.Error.to_extension + |> List.map ~f:(EC.node_of_extension context ~x) + | Error l -> + l + |> NonEmptyList.map ~f:Location.Error.to_extension + |> NonEmptyList.map ~f:(EC.node_of_extension context ~x) + |> NonEmptyList.to_list)) let map_nodes = map_nodes ~in_generated_code:false @@ -295,10 +313,13 @@ attached, [get_group] returns the equivalent of [Some (List.map ~f:(Attribute.get attr) l)]. *) let rec get_group attr l = + let open Result in match l with - | [] -> None + | [] -> Ok None | x :: l -> ( - match (Attribute.get attr x, get_group attr l) with + get_group attr l >>= fun group -> + Attribute.get_res attr x >>| fun attr2 -> + match (attr2, group) with | None, None -> None | None, Some vals -> Some (None :: vals) | Some value, None -> Some (Some value :: List.map l ~f:(fun _ -> None)) @@ -324,8 +345,10 @@ (Rule.Attr_inline.attr_name b)) let context_free_attribute_modification ~loc = - Location.raise_errorf ~loc - "A context-free rule deleted or added attribues of a str/sig item" + Error + ( Location.Error.createf ~loc + "A context-free rule deleted or added attribues of a str/sig item", + [] ) (* Returns the code generated by attribute handlers. We don't remove these attributes, as another pass might interpret them later. For instance both ppx_deriving and @@ -335,12 +358,14 @@ of one element; it only has [@@deriving]. *) let handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt = - List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_group_inline.T group) -> - match - ( get_group group.attribute items, - get_group group.attribute expanded_items ) - with - | None, None -> acc + let open Result in + List.fold_left attrs ~init:(Ok []) + ~f:(fun acc (Rule.Attr_group_inline.T group) -> + acc >>= fun acc -> + get_group group.attribute items >>= fun g1 -> + get_group group.attribute expanded_items >>= fun g2 -> + match (g1, g2) with + | None, None -> Ok acc | None, Some _ | Some _, None -> context_free_attribute_modification ~loc | Some values, Some _ -> let ctxt = @@ -348,14 +373,16 @@ ~inline:group.expect ~base:base_ctxt () in let expect_items = group.expand ~ctxt rf expanded_items values in - expect_items :: acc) + Ok (expect_items :: acc)) let handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt = - List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_inline.T a) -> - match - (Attribute.get a.attribute item, Attribute.get a.attribute expanded_item) - with - | None, None -> acc + let open Result in + List.fold_left attrs ~init:(Ok []) ~f:(fun acc (Rule.Attr_inline.T a) -> + acc >>= fun acc -> + Attribute.get_res a.attribute item >>= fun g1 -> + Attribute.get_res a.attribute expanded_item >>= fun g2 -> + match (g1, g2) with + | None, None -> Ok acc | None, Some _ | Some _, None -> context_free_attribute_modification ~loc | Some value, Some _ -> let ctxt = @@ -363,7 +390,7 @@ ~inline:a.expect ~base:base_ctxt () in let expect_items = a.expand ~ctxt expanded_item value in - expect_items :: acc) + Ok (expect_items :: acc)) module Expect_mismatch_handler = struct type t = { @@ -571,6 +598,7 @@ (* TODO: try to factorize #structure and #signature without meta-programming *) (*$*) method! structure base_ctxt st = + let open Result in let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = let extra_items = @@ -581,15 +609,16 @@ (Many extra_items); let original_rest = rest in let rest = loop rest ~in_generated_code in + let open Result in (match expect_items with - | [] -> () + | [] -> Ok () | _ -> let expected = rev_concat expect_items in let pos = item.pstr_loc.loc_end in - Code_matcher.match_structure original_rest ~pos ~expected + Code_matcher.match_structure_res original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> - expect_mismatch_handler.f Structure_item loc repl)); - item :: (extra_items @ rest) + expect_mismatch_handler.f Structure_item loc repl)) + >>| fun () -> item :: (extra_items @ rest) and loop st ~in_generated_code = match st with | [] -> [] @@ -602,68 +631,90 @@ Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline structure_item ~ctxt ext with - | None -> + match + E.For_context.convert_inline_res structure_item ~ctxt ext + with + | Ok None -> let item = super#structure_item base_ctxt item in let rest = self#structure base_ctxt rest in item :: rest - | Some items -> - assert_no_attributes attrs; - let items = loop items ~in_generated_code:true in - if not in_generated_code then - Generated_code_hook.replace hook Structure_item - item.pstr_loc (Many items); - items @ loop rest ~in_generated_code) + | Ok (Some items) -> + let attributes_errors = attributes_errors attrs in + if List.length attributes_errors = 0 then ( + (* assert_no_attributes attrs; *) + let items = loop items ~in_generated_code:true in + if not in_generated_code then + Generated_code_hook.replace hook Structure_item + item.pstr_loc (Many items); + items @ loop rest ~in_generated_code) + else + (attributes_errors + |> List.map ~f:Location.Error.to_extension + |> List.map + ~f:(EC.node_of_extension EC.Structure_item ~x:item)) + @ loop rest ~in_generated_code + | Error err -> + (err + |> NonEmptyList.map ~f:Location.Error.to_extension + |> NonEmptyList.map + ~f:(EC.node_of_extension EC.Structure_item ~x:item) + |> NonEmptyList.to_list) + @ loop rest ~in_generated_code) | _ -> ( + let error_of_extension e = + (e + |> NonEmptyList.map ~f:Location.Error.to_extension + |> NonEmptyList.map ~f:(fun e -> + Ast_builder.Default.pstr_extension ~loc:Location.none e + []) + |> NonEmptyList.to_list) + @ loop rest ~in_generated_code + in let expanded_item = super#structure_item base_ctxt item in match (item.pstr_desc, expanded_item.pstr_desc) with | Pstr_type (rf, tds), Pstr_type (exp_rf, exp_tds) -> (* No context-free rule can rewrite rec flags atm, this assert acts as a failsafe in case it ever changes *) assert (Poly.(rf = exp_rf)); - let extra_items = - handle_attr_group_inline attr_str_type_decls rf ~items:tds - ~expanded_items:exp_tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_str_type_decls_expect rf - ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_group_inline attr_str_type_decls rf ~items:tds + ~expanded_items:exp_tds ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_group_inline attr_str_type_decls_expect rf + ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Pstr_modtype mtd, Pstr_modtype exp_mtd -> - let extra_items = - handle_attr_inline attr_str_module_type_decls ~item:mtd - ~expanded_item:exp_mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_str_module_type_decls_expect - ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_str_module_type_decls ~item:mtd + ~expanded_item:exp_mtd ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_str_module_type_decls_expect + ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Pstr_typext te, Pstr_typext exp_te -> - let extra_items = - handle_attr_inline attr_str_type_exts ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_str_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_str_type_exts ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_str_type_exts_expect ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Pstr_exception ec, Pstr_exception exp_ec -> - let extra_items = - handle_attr_inline attr_str_exceptions ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_str_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_str_exceptions ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_str_exceptions_expect ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | _, _ -> let rest = self#structure base_ctxt rest in expanded_item :: rest)) @@ -672,6 +723,7 @@ (*$ str_to_sig _last_text_block *) method! signature base_ctxt sg = + let open Result in let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = let extra_items = @@ -682,15 +734,16 @@ (Many extra_items); let original_rest = rest in let rest = loop rest ~in_generated_code in + let open Result in (match expect_items with - | [] -> () + | [] -> Ok () | _ -> let expected = rev_concat expect_items in let pos = item.psig_loc.loc_end in - Code_matcher.match_signature original_rest ~pos ~expected + Code_matcher.match_signature_res original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> - expect_mismatch_handler.f Signature_item loc repl)); - item :: (extra_items @ rest) + expect_mismatch_handler.f Signature_item loc repl)) + >>| fun () -> item :: (extra_items @ rest) and loop sg ~in_generated_code = match sg with | [] -> [] @@ -703,68 +756,90 @@ Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in - match E.For_context.convert_inline signature_item ~ctxt ext with - | None -> + match + E.For_context.convert_inline_res signature_item ~ctxt ext + with + | Ok None -> let item = super#signature_item base_ctxt item in let rest = self#signature base_ctxt rest in item :: rest - | Some items -> - assert_no_attributes attrs; - let items = loop items ~in_generated_code:true in - if not in_generated_code then - Generated_code_hook.replace hook Signature_item - item.psig_loc (Many items); - items @ loop rest ~in_generated_code) + | Ok (Some items) -> + let attributes_errors = attributes_errors attrs in + if List.length attributes_errors = 0 then ( + (* assert_no_attributes attrs; *) + let items = loop items ~in_generated_code:true in + if not in_generated_code then + Generated_code_hook.replace hook Signature_item + item.psig_loc (Many items); + items @ loop rest ~in_generated_code) + else + (attributes_errors + |> List.map ~f:Location.Error.to_extension + |> List.map + ~f:(EC.node_of_extension EC.Signature_item ~x:item)) + @ loop rest ~in_generated_code + | Error err -> + (err + |> NonEmptyList.map ~f:Location.Error.to_extension + |> NonEmptyList.map + ~f:(EC.node_of_extension EC.Signature_item ~x:item) + |> NonEmptyList.to_list) + @ loop rest ~in_generated_code) | _ -> ( + let error_of_extension e = + (e + |> NonEmptyList.map ~f:Location.Error.to_extension + |> NonEmptyList.map ~f:(fun e -> + Ast_builder.Default.psig_extension ~loc:Location.none e + []) + |> NonEmptyList.to_list) + @ loop rest ~in_generated_code + in let expanded_item = super#signature_item base_ctxt item in match (item.psig_desc, expanded_item.psig_desc) with | Psig_type (rf, tds), Psig_type (exp_rf, exp_tds) -> (* No context-free rule can rewrite rec flags atm, this assert acts as a failsafe in case it ever changes *) assert (Poly.(rf = exp_rf)); - let extra_items = - handle_attr_group_inline attr_sig_type_decls rf ~items:tds - ~expanded_items:exp_tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_sig_type_decls_expect rf - ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_group_inline attr_sig_type_decls rf ~items:tds + ~expanded_items:exp_tds ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_group_inline attr_sig_type_decls_expect rf + ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Psig_modtype mtd, Psig_modtype exp_mtd -> - let extra_items = - handle_attr_inline attr_sig_module_type_decls ~item:mtd - ~expanded_item:exp_mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_sig_module_type_decls_expect - ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_sig_module_type_decls ~item:mtd + ~expanded_item:exp_mtd ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_sig_module_type_decls_expect + ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Psig_typext te, Psig_typext exp_te -> - let extra_items = - handle_attr_inline attr_sig_type_exts ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_sig_type_exts_expect ~item:te - ~expanded_item:exp_te ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_sig_type_exts ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_sig_type_exts_expect ~item:te + ~expanded_item:exp_te ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | Psig_exception ec, Psig_exception exp_ec -> - let extra_items = - handle_attr_inline attr_sig_exceptions ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_sig_exceptions_expect ~item:ec - ~expanded_item:exp_ec ~loc ~base_ctxt - in - with_extra_items expanded_item ~extra_items ~expect_items - ~rest ~in_generated_code + handle_attr_inline attr_sig_exceptions ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + >>= (fun extra_items -> + handle_attr_inline attr_sig_exceptions_expect ~item:ec + ~expanded_item:exp_ec ~loc ~base_ctxt + >>= fun expect_items -> + with_extra_items expanded_item ~extra_items + ~expect_items ~rest ~in_generated_code) + |> handle_error ~f:error_of_extension | _, _ -> let rest = self#signature base_ctxt rest in expanded_item :: rest)) diff -Nru ppxlib-0.24.0/src/context_free.mli ppxlib-0.27.0/src/context_free.mli --- ppxlib-0.24.0/src/context_free.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/context_free.mli 2022-06-14 18:16:33.000000000 +0000 @@ -101,15 +101,10 @@ (signature_item, module_type_declaration, _) attr_inline val attr_str_type_ext : (structure_item, type_extension, _) attr_inline - val attr_sig_type_ext : (signature_item, type_extension, _) attr_inline - val attr_str_type_ext_expect : (structure_item, type_extension, _) attr_inline - val attr_sig_type_ext_expect : (signature_item, type_extension, _) attr_inline - val attr_str_exception : (structure_item, type_exception, _) attr_inline - val attr_sig_exception : (signature_item, type_exception, _) attr_inline val attr_str_exception_expect : diff -Nru ppxlib-0.24.0/src/deriving.ml ppxlib-0.27.0/src/deriving.ml --- ppxlib-0.24.0/src/deriving.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/deriving.ml 2022-06-14 18:16:33.000000000 +0000 @@ -5,9 +5,7 @@ contains compiler attribute to disable unused warnings, instead of inserting [let _ = ... ]. *) let do_insert_unused_warning_attribute = ref false - let keep_w32_impl = ref false - let keep_w32_intf = ref false let () = @@ -40,11 +38,8 @@ ~doc:" Deprecated, use -deriving-disable-w32-method" let keep_w32_impl () = !keep_w32_impl || Driver.pretty () - let keep_w32_intf () = !keep_w32_intf || Driver.pretty () - let keep_w60_impl = ref false - let keep_w60_intf = ref false let () = @@ -63,7 +58,6 @@ ~doc:" Do not try to disable warning 60 for the generated code" let keep_w60_impl () = !keep_w60_impl || Driver.pretty () - let keep_w60_intf () = !keep_w60_intf || Driver.pretty () module Args = struct @@ -96,7 +90,6 @@ | Cons : ('m1, 'a -> 'm2) t * 'a param -> ('m1, 'm2) t let empty = Nil - let ( +> ) a b = Cons (a, b) let rec names : type a b. (a, b) t -> string list = function @@ -177,38 +170,64 @@ loop String.Set.empty l let check_arguments name generators (args : (string * expression) list) = - List.iter args ~f:(fun (label, e) -> - if String.is_empty label then - Location.raise_errorf ~loc:e.pexp_loc - "Ppxlib.Deriving: generator arguments must be labelled"); - Option.iter - (List.find_a_dup args ~compare:(fun (a, _) (b, _) -> String.compare a b)) - ~f:(fun (label, e) -> - Location.raise_errorf ~loc:e.pexp_loc - "Ppxlib.Deriving: argument labelled '%s' appears more than once" label); + let empty_label_error = + List.filter_map args ~f:(fun (label, e) -> + if String.is_empty label then + Some + (Location.error_extensionf ~loc:e.pexp_loc + "Ppxlib.Deriving: generator arguments must be labelled") + else None) + in + let duplicate_argument_error = + Option.map + (List.find_a_dup args ~compare:(fun (a, _) (b, _) -> String.compare a b)) + ~f:(fun (label, e) -> + Location.error_extensionf ~loc:e.pexp_loc + "Ppxlib.Deriving: argument labelled '%s' appears more than once" + label) + |> Option.to_list + in let accepted_args = merge_accepted_args generators in - List.iter args ~f:(fun (label, e) -> - if not (String.Set.mem label accepted_args) then - let spellcheck_msg = - match - Spellcheck.spellcheck (String.Set.elements accepted_args) label - with - | None -> "" - | Some s -> ".\n" ^ s - in - Location.raise_errorf ~loc:e.pexp_loc - "Ppxlib.Deriving: generator '%s' doesn't accept argument '%s'%s" - name label spellcheck_msg) + let unaccepted_argument = + List.filter_map args ~f:(fun (label, e) -> + if not (String.Set.mem label accepted_args) then + let spellcheck_msg = + match + Spellcheck.spellcheck (String.Set.elements accepted_args) label + with + | None -> "" + | Some s -> ".\n" ^ s + in + Some + (Location.error_extensionf ~loc:e.pexp_loc + "Ppxlib.Deriving: generator '%s' doesn't accept argument \ + '%s'%s" + name label spellcheck_msg) + else None) + in + let errors = + empty_label_error @ duplicate_argument_error @ unaccepted_argument + in + if List.length errors = 0 then Ok () else Error errors let apply (T t) ~name:_ ~ctxt x args = Args.apply t.spec args (t.gen ~ctxt x) let apply_all ~ctxt entry (name, generators, args) = - check_arguments name.txt generators args; + let open Result in + check_arguments name.txt generators args >>| fun () -> List.concat_map generators ~f:(fun t -> apply t ~name:name.txt ~ctxt entry args) - let apply_all ~ctxt entry generators = - List.concat_map generators ~f:(apply_all ~ctxt entry) + let apply_all ~ctxt entry generators ext_to_item = + let l = List.map generators ~f:(apply_all ~ctxt entry) in + let l1, lerr = + List.partition_map (function Ok e -> Left e | Error e -> Right e) l + in + let lerr = + List.concat lerr + |> List.map ~f:(fun err -> ext_to_item ~loc:Location.none err []) + in + List.concat l1 @ lerr end module Deriver = struct @@ -321,7 +340,6 @@ end type t = Actual_deriver of Actual_deriver.t | Alias of Alias.t - type Ppx_derivers.deriver += T of t let derivers () = @@ -368,54 +386,77 @@ | Some s -> ".\n" ^ s else "" in - Location.raise_errorf ~loc:name.loc + Location.error_extensionf ~loc:name.loc "Ppxlib.Deriving: '%s' is not a supported %s deriving generator%s" name.txt field.name spellcheck_msg let resolve field name = - try resolve_internal field name.txt + try Ok (resolve_internal field name.txt) with Not_supported name' -> - not_supported field ~spellcheck:(String.equal name.txt name') name + Error (not_supported field ~spellcheck:(String.equal name.txt name') name) let resolve_all field derivers = - let derivers_and_args = - List.filter_map derivers ~f:(fun (name, args) -> + let derivers_and_args, derivers_and_args_errors = + List.partition_map + (fun (name, args) -> match Ppx_derivers.lookup name.txt with - | None -> not_supported field name - | Some (T _) -> + | None -> Either.Right (not_supported field name) + | Some (T _) -> ( (* It's one of ours, parse the arguments now. We can't do it before since ppx_deriving uses a different syntax for arguments. *) - Some - ( name, - match args with - | Args l -> l - | Unknown_syntax (loc, msg) -> - Location.raise_errorf ~loc "Ppxlib.Deriving: %s" msg ) + match args with + | Args l -> Either.Left (Some (name, l)) + | Unknown_syntax (loc, msg) -> + Either.Right + (Location.error_extensionf ~loc "Ppxlib.Deriving: %s" msg)) | Some _ -> (* It's not one of ours, ignore it. *) - None) + Either.Left None) + derivers + |> fun (l1, l2) -> (List.filter_opt l1, l2) in (* Set of actual deriver names *) let seen = Hashtbl.create 16 in - List.map derivers_and_args ~f:(fun (name, args) -> - let named_generators = resolve field name in - List.iter named_generators ~f:(fun (actual_deriver_name, gen) -> - if - Options.fail_on_duplicate_derivers - && Hashtbl.mem seen actual_deriver_name - then - Location.raise_errorf ~loc:name.loc "Deriver %s appears twice" - actual_deriver_name; - List.iter (Generator.deps gen) ~f:(fun dep -> - List.iter (resolve_actual_derivers field dep) ~f:(fun drv -> - let dep_name = drv.name in - if not (Hashtbl.mem seen dep_name) then - Location.raise_errorf ~loc:name.loc - "Deriver %s is needed for %s, you need to add it \ - before in the list" - dep_name name.txt)); - Hashtbl.set seen ~key:actual_deriver_name ~data:()); - (name, List.map named_generators ~f:snd, args)) + let result, dep_errors = + List.fold_left ~init:([], []) derivers_and_args + ~f:(fun (result, errors) (name, args) -> + match resolve field name with + | Error e -> (result, errors @ [ e ]) + | Ok named_generators -> + let l_err = + List.concat_map named_generators + ~f:(fun (actual_deriver_name, gen) -> + let dup_error = + if + Options.fail_on_duplicate_derivers + && Hashtbl.mem seen actual_deriver_name + then + [ + Location.error_extensionf ~loc:name.loc + "Deriver %s appears twice" actual_deriver_name; + ] + else [] + in + let l_err = + List.concat_map (Generator.deps gen) ~f:(fun dep -> + List.filter_map (resolve_actual_derivers field dep) + ~f:(fun drv -> + let dep_name = drv.name in + if not (Hashtbl.mem seen dep_name) then + Some + (Location.error_extensionf ~loc:name.loc + "Deriver %s is needed for %s, you need to \ + add it before in the list" + dep_name name.txt) + else None)) + in + Hashtbl.set seen ~key:actual_deriver_name ~data:(); + dup_error @ l_err) + in + ( result @ [ (name, List.map named_generators ~f:snd, args) ], + errors @ l_err )) + in + (result, derivers_and_args_errors @ dep_errors) let add ?str_type_decl ?str_type_ext ?str_exception ?str_module_type_decl ?sig_type_decl ?sig_type_ext ?sig_exception ?sig_module_type_decl @@ -467,7 +508,6 @@ end let add = Deriver.add - let add_alias = Deriver.add_alias (* +-----------------------------------------------------------------+ @@ -661,12 +701,19 @@ List.filter_map l ~f:(fun x -> x) |> List.concat |> Deriver.resolve_all field let expand_str_type_decls ~ctxt rec_flag tds values = - let generators = merge_generators Deriver.Field.str_type_decl values in + let generators, l_err = merge_generators Deriver.Field.str_type_decl values in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.pstr_extension ~loc:Location.none err []) + l_err + in (* TODO: instead of disabling the unused warning for types themselves, we should add a tag [@@unused]. *) let generated = - types_used_by_deriving tds + types_used_by_deriving tds @ l_err @ Generator.apply_all ~ctxt (rec_flag, tds) generators + Ast_builder.Default.pstr_extension in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) @@ -674,60 +721,135 @@ generated let expand_sig_type_decls ~ctxt rec_flag tds values = - let generators = merge_generators Deriver.Field.sig_type_decl values in - let generated = Generator.apply_all ~ctxt (rec_flag, tds) generators in + let generators, l_err = merge_generators Deriver.Field.sig_type_decl values in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.psig_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt (rec_flag, tds) generators + Ast_builder.Default.psig_extension + in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_module_type_decl ~ctxt mtd generators = - let generators = + let generators, l_err = Deriver.resolve_all Deriver.Field.str_module_type_decl generators in - let generated = Generator.apply_all ~ctxt mtd generators in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.pstr_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt mtd generators + Ast_builder.Default.pstr_extension + in + wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_module_type_decl ~ctxt mtd generators = - let generators = + let generators, l_err = Deriver.resolve_all Deriver.Field.sig_module_type_decl generators in - let generated = Generator.apply_all ~ctxt mtd generators in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.psig_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt mtd generators + Ast_builder.Default.psig_extension + in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_exception ~ctxt ec generators = - let generators = Deriver.resolve_all Deriver.Field.str_exception generators in - let generated = Generator.apply_all ~ctxt ec generators in + let generators, l_err = + Deriver.resolve_all Deriver.Field.str_exception generators + in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.pstr_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt ec generators Ast_builder.Default.pstr_extension + in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_exception ~ctxt ec generators = - let generators = Deriver.resolve_all Deriver.Field.sig_exception generators in - let generated = Generator.apply_all ~ctxt ec generators in + let generators, l_err = + Deriver.resolve_all Deriver.Field.sig_exception generators + in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.psig_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt ec generators Ast_builder.Default.psig_extension + in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_type_ext ~ctxt te generators = - let generators = Deriver.resolve_all Deriver.Field.str_type_ext generators in - let generated = Generator.apply_all ~ctxt te generators in + let generators, l_err = + Deriver.resolve_all Deriver.Field.str_type_ext generators + in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.pstr_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt te generators Ast_builder.Default.pstr_extension + in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_type_ext ~ctxt te generators = - let generators = Deriver.resolve_all Deriver.Field.sig_type_ext generators in - let generated = Generator.apply_all ~ctxt te generators in + let generators, l_err = + Deriver.resolve_all Deriver.Field.sig_type_ext generators + in + let l_err = + List.map + ~f:(fun err -> + Ast_builder.Default.psig_extension ~loc:Location.none err []) + l_err + in + let generated = + l_err + @ Generator.apply_all ~ctxt te generators Ast_builder.Default.psig_extension + in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) diff -Nru ppxlib-0.24.0/src/deriving.mli ppxlib-0.27.0/src/deriving.mli --- ppxlib-0.24.0/src/deriving.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/deriving.mli 2022-06-14 18:16:33.000000000 +0000 @@ -5,7 +5,6 @@ (** Specification of generator arguments *) module Args : sig type ('a, 'b) t - type 'a param val empty : ('m, 'm) t @@ -44,7 +43,6 @@ module Generator : sig type deriver = t - type ('output_ast, 'input_ast) t val make : diff -Nru ppxlib-0.24.0/src/driver.ml ppxlib-0.27.0/src/driver.ml --- ppxlib-0.24.0/src/driver.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/driver.ml 2022-06-14 18:16:33.000000000 +0000 @@ -4,41 +4,23 @@ module Arg = Caml.Arg let exe_name = Caml.Filename.basename Caml.Sys.executable_name - let args = ref [] - let add_arg key spec ~doc = args := (key, spec, doc) :: !args - let loc_fname = ref None - let perform_checks = ref Options.perform_checks - let perform_checks_on_extensions = ref Options.perform_checks_on_extensions - let perform_locations_check = ref Options.perform_locations_check - let debug_attribute_drop = ref false - let apply_list = ref None - let preprocessor = ref None - let no_merge = ref false - let request_print_passes = ref false - let request_print_transformations = ref false - let use_color = ref true - let diff_command = ref Options.diff_command - let pretty = ref false - let styler = ref None - let output_metadata_filename = ref None - let corrected_suffix = ref ".ppx-corrected" module Lint_error = struct @@ -57,22 +39,28 @@ let e = Selected_ast.of_ocaml Expression e in Ast_pattern.parse pattern e.pexp_loc e Fn.id) + let get_res T name pattern = + match + Option.map (Astlib.Ast_metadata.get_cookie name) ~f:(fun e -> + let e = Selected_ast.of_ocaml Expression e in + Ast_pattern.parse_res pattern e.pexp_loc e Fn.id) + with + | None -> Ok None + | Some (Ok e) -> Ok (Some e) + | Some (Error e) -> Error e + let set T name expr = Astlib.Ast_metadata.set_cookie name (Selected_ast.to_ocaml Expression expr) let handlers = ref [] - let add_handler f = handlers := !handlers @ [ f ] let add_simple_handler name pattern ~f = add_handler (fun T -> f (get T name pattern)) let acknowledge_cookies T = List.iter !handlers ~f:(fun f -> f T) - let post_handlers = ref [] - let add_post_handler f = post_handlers := !post_handlers @ [ f ] - let call_post_handlers T = List.iter !post_handlers ~f:(fun f -> f T) end @@ -243,9 +231,7 @@ in gen_header_and_footer Structure_item whole_loc (f base_ctxt) in - let attrs = map#structure base_ctxt attrs in - let st = map#structure base_ctxt st in - List.concat [ attrs; header; st; footer ] + map#structure base_ctxt (List.concat [ attrs; header; st; footer ]) in match impl with None -> st | Some f -> f ctxt st in @@ -269,9 +255,7 @@ in gen_header_and_footer Signature_item whole_loc (f base_ctxt) in - let attrs = map#signature base_ctxt attrs in - let sg = map#signature base_ctxt sg in - List.concat [ attrs; header; sg; footer ] + map#signature base_ctxt (List.concat [ attrs; header; sg; footer ]) in match intf with None -> sg | Some f -> f ctxt sg in @@ -313,9 +297,13 @@ in match Option.map t.instrument ~f with | Some (Before, transf) -> - ({ reduced_t with impl = Some transf } :: bef_i, aft_i, rest) + ( { reduced_t with impl = Some transf; rules = [] } :: bef_i, + aft_i, + reduced_t :: rest ) | Some (After, transf) -> - (bef_i, { reduced_t with impl = Some transf } :: aft_i, rest) + ( bef_i, + { reduced_t with impl = Some transf; rules = [] } :: aft_i, + reduced_t :: rest ) | None -> (bef_i, aft_i, reduced_t :: rest)) in ( `Linters @@ -493,47 +481,99 @@ |> List.filter ~f:(fun (ct : Transform.t) -> match (ct.impl, ct.intf) with None, None -> false | _ -> true) in - linters @ preprocess @ make_generic before_instrs @ make_generic cts - @ make_generic after_instrs + linters @ preprocess @ before_instrs @ make_generic cts @ after_instrs -let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far - ~hook ~expect_mismatch_handler ~input_name x = +let apply_transforms (type t) ~tool_name ~file_path ~field ~lint_field + ~dropped_so_far ~hook ~expect_mismatch_handler ~input_name ~f_exception + ~embed_errors x = + let exception + Wrapper of t list * label loc list * (location * label) list * exn + in let cts = get_whole_ast_passes ~tool_name ~hook ~expect_mismatch_handler ~input_name in - let x, _dropped, lint_errors = - List.fold_left cts ~init:(x, [], []) - ~f:(fun (x, dropped, lint_errors) (ct : Transform.t) -> - let input_name = - match input_name with - | Some input_name -> input_name - | None -> "_none_" - in - let ctxt = - Expansion_context.Base.top_level ~tool_name ~file_path ~input_name - in - let lint_errors = - match lint_field ct with - | None -> lint_errors - | Some f -> lint_errors @ f ctxt x - in - match field ct with - | None -> (x, dropped, lint_errors) - | Some f -> - let x = f ctxt x in - let dropped = - if !debug_attribute_drop then ( - let new_dropped = dropped_so_far x in - debug_dropped_attribute ct.name ~old_dropped:dropped - ~new_dropped; - new_dropped) - else [] - in - (x, dropped, lint_errors)) - in - ( x, - List.map lint_errors ~f:(fun (loc, s) -> Common.attribute_of_warning loc s) - ) + let return (x, _dropped, lint_errors) = + ( x, + List.map lint_errors ~f:(fun (loc, s) -> + Common.attribute_of_warning loc s) ) + in + try + let acc = + List.fold_left cts ~init:(x, [], []) + ~f:(fun (x, dropped, (lint_errors : _ list)) (ct : Transform.t) -> + let input_name = + match input_name with + | Some input_name -> input_name + | None -> "_none_" + in + let ctxt = + Expansion_context.Base.top_level ~tool_name ~file_path ~input_name + in + let lint_errors = + match lint_field ct with + | None -> lint_errors + | Some f -> ( + try lint_errors @ f ctxt x + with exn when embed_errors -> + raise @@ Wrapper (x, dropped, lint_errors, exn)) + in + match field ct with + | None -> (x, dropped, lint_errors) + | Some f -> + let x = + try f ctxt x + with exn when embed_errors -> + raise @@ Wrapper (x, dropped, lint_errors, exn) + in + let dropped = + if !debug_attribute_drop then ( + let new_dropped = dropped_so_far x in + debug_dropped_attribute ct.name ~old_dropped:dropped + ~new_dropped; + new_dropped) + else [] + in + (x, dropped, lint_errors)) + in + Ok (return acc) + with Wrapper (x, dropped, lint_errors, exn) -> + Error (return (f_exception exn :: x, dropped, lint_errors)) + +(*$*) + +let error_to_str_extension error = + let loc = Location.none in + let ext = Location.Error.to_extension error in + Ast_builder.Default.pstr_extension ~loc ext [] + +let exn_to_str_extension exn = + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> error_to_str_extension error + +(*$ str_to_sig _last_text_block *) + +let error_to_sig_extension error = + let loc = Location.none in + let ext = Location.Error.to_extension error in + Ast_builder.Default.psig_extension ~loc ext [] + +let exn_to_sig_extension exn = + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> error_to_sig_extension error + +(*$*) + +let error_to_extension error ~(kind : Kind.t) = + match kind with + | Intf -> Intf_or_impl.Intf [ error_to_sig_extension error ] + | Impl -> Intf_or_impl.Impl [ error_to_str_extension error ] + +let exn_to_extension exn ~(kind : Kind.t) = + match Location.Error.of_exn exn with + | None -> raise exn + | Some error -> error_to_extension error ~kind (* +-----------------------------------------------------------------+ | Actual rewriting of structure/signatures | @@ -556,92 +596,154 @@ Printf.printf "\n") (*$*) -let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name = + +let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name + ~embed_errors = Cookies.acknowledge_cookies T; if !perform_checks then ( Attribute.reset_checks (); Attribute.collect#structure st); - let st, lint_errors = - let file_path = File_path.get_default_path_str st in + let lint lint_errors st = + let st = + match lint_errors with + | [] -> st + | _ -> + List.map lint_errors + ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> + Ast_builder.Default.pstr_attribute ~loc attr) + @ st + in + st + in + let cookies_and_check st = + Cookies.call_post_handlers T; + let errors = + if !perform_checks then ( + (* TODO: these two passes could be merged, we now have more passes for + checks than for actual rewriting. *) + let unused_attributes_errors = + Attribute.collect_unused_attributes_errors#structure st [] + in + let unused_extension_errors = + if !perform_checks_on_extensions then + Extension.collect_unhandled_extension_errors#structure st [] + else [] + in + let not_seen_errors = Attribute.collect_unseen_errors () in + (if !perform_locations_check then + let open Location_check in + ignore + ((enforce_invariants !loc_fname)#structure st + Non_intersecting_ranges.empty + : Non_intersecting_ranges.t)); + let errors = + unused_attributes_errors @ unused_extension_errors @ not_seen_errors + in + errors + |> List.map ~f:Location.Error.to_extension + |> List.map ~f:(fun e -> + Ast_builder.Default.pstr_extension ~loc:Location.none e [])) + else [] + in + errors @ st + in + let file_path = File_path.get_default_path_str st in + match apply_transforms st ~tool_name ~file_path ~field:(fun (ct : Transform.t) -> ct.impl) ~lint_field:(fun (ct : Transform.t) -> ct.lint_impl) ~dropped_so_far:Attribute.dropped_so_far_structure ~hook ~expect_mismatch_handler ~input_name - in - let st = - match lint_errors with - | [] -> st - | _ -> - List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> - Ast_builder.Default.pstr_attribute ~loc attr) - @ st - in - Cookies.call_post_handlers T; - if !perform_checks then ( - (* TODO: these two passes could be merged, we now have more passes for - checks than for actual rewriting. *) - Attribute.check_unused#structure st; - if !perform_checks_on_extensions then Extension.check_unused#structure st; - Attribute.check_all_seen (); - if !perform_locations_check then - let open Location_check in - ignore - ((enforce_invariants !loc_fname)#structure st - Non_intersecting_ranges.empty - : Non_intersecting_ranges.t)); - st + ~f_exception:(fun exn -> exn_to_str_extension exn) + ~embed_errors + with + | Error (st, lint_errors) -> Error (lint lint_errors st) + | Ok (st, lint_errors) -> Ok (st |> lint lint_errors |> cookies_and_check) let map_structure st = - map_structure_gen st - ~tool_name:(Astlib.Ast_metadata.tool_name ()) - ~hook:Context_free.Generated_code_hook.nop - ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop - ~input_name:None + match + map_structure_gen st + ~tool_name:(Astlib.Ast_metadata.tool_name ()) + ~hook:Context_free.Generated_code_hook.nop + ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop + ~input_name:None ~embed_errors:false + with + | Ok ast | Error ast -> ast (*$ str_to_sig _last_text_block *) -let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name = + +let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name + ~embed_errors = Cookies.acknowledge_cookies T; if !perform_checks then ( Attribute.reset_checks (); Attribute.collect#signature sg); - let sg, lint_errors = - let file_path = File_path.get_default_path_sig sg in + let lint lint_errors sg = + let sg = + match lint_errors with + | [] -> sg + | _ -> + List.map lint_errors + ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> + Ast_builder.Default.psig_attribute ~loc attr) + @ sg + in + sg + in + let cookies_and_check sg = + Cookies.call_post_handlers T; + let errors = + if !perform_checks then ( + (* TODO: these two passes could be merged, we now have more passes for + checks than for actual rewriting. *) + let unused_attributes_errors = + Attribute.collect_unused_attributes_errors#signature sg [] + in + let unused_extension_errors = + if !perform_checks_on_extensions then + Extension.collect_unhandled_extension_errors#signature sg [] + else [] + in + let not_seen_errors = Attribute.collect_unseen_errors () in + (if !perform_locations_check then + let open Location_check in + ignore + ((enforce_invariants !loc_fname)#signature sg + Non_intersecting_ranges.empty + : Non_intersecting_ranges.t)); + let errors = + unused_attributes_errors @ unused_extension_errors @ not_seen_errors + in + errors + |> List.map ~f:Location.Error.to_extension + |> List.map ~f:(fun e -> + Ast_builder.Default.psig_extension ~loc:Location.none e [])) + else [] + in + errors @ sg + in + let file_path = File_path.get_default_path_sig sg in + match apply_transforms sg ~tool_name ~file_path ~field:(fun (ct : Transform.t) -> ct.intf) ~lint_field:(fun (ct : Transform.t) -> ct.lint_intf) ~dropped_so_far:Attribute.dropped_so_far_signature ~hook ~expect_mismatch_handler ~input_name - in - let sg = - match lint_errors with - | [] -> sg - | _ -> - List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _ } as attr) -> - Ast_builder.Default.psig_attribute ~loc attr) - @ sg - in - Cookies.call_post_handlers T; - if !perform_checks then ( - (* TODO: these two passes could be merged, we now have more passes for - checks than for actual rewriting. *) - Attribute.check_unused#signature sg; - if !perform_checks_on_extensions then Extension.check_unused#signature sg; - Attribute.check_all_seen (); - if !perform_locations_check then - let open Location_check in - ignore - ((enforce_invariants !loc_fname)#signature sg - Non_intersecting_ranges.empty - : Non_intersecting_ranges.t)); - sg + ~f_exception:(fun exn -> exn_to_sig_extension exn) + ~embed_errors + with + | Error (sg, lint_errors) -> Error (lint lint_errors sg) + | Ok (sg, lint_errors) -> Ok (sg |> lint lint_errors |> cookies_and_check) let map_signature sg = - map_signature_gen sg - ~tool_name:(Astlib.Ast_metadata.tool_name ()) - ~hook:Context_free.Generated_code_hook.nop - ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop - ~input_name:None + match + map_signature_gen sg + ~tool_name:(Astlib.Ast_metadata.tool_name ()) + ~hook:Context_free.Generated_code_hook.nop + ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop + ~input_name:None ~embed_errors:false + with + | Ok ast | Error ast -> ast (*$*) @@ -851,7 +953,6 @@ | Impl x -> Impl (add_cookies_str x) let corrections = ref [] - let add_to_list r x = r := x :: !r let register_correction ~loc ~repl = @@ -860,7 +961,6 @@ ~repl) let process_file_hooks = ref [] - let register_process_file_hook f = add_to_list process_file_hooks f module File_property = struct @@ -873,9 +973,7 @@ type packed = T : _ t -> packed let all = ref [] - let register t = add_to_list all (T t) - let reset_all () = List.iter !all ~f:(fun (T t) -> t.data <- None) let dump_and_reset_all () = @@ -896,37 +994,30 @@ { name = Name.name; data = None; sexp_of_t = T.sexp_of_t } let () = File_property.register t - let set x = t.data <- Some x end -let error_to_extension error ~(kind : Kind.t) = - let loc = Location.none in - let ext = Location.Error.to_extension error in - let open Ast_builder.Default in - let ast = - match kind with - | Intf -> Intf_or_impl.Intf [ psig_extension ~loc ext [] ] - | Impl -> Intf_or_impl.Impl [ pstr_extension ~loc ext [] ] - in - ast - -let exn_to_extension exn ~(kind : Kind.t) = - match Location.Error.of_exn exn with - | None -> raise exn - | Some error -> error_to_extension error ~kind - let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook - ~expect_mismatch_handler = + ~expect_mismatch_handler ~embed_errors = match ast with | Intf x -> - Intf_or_impl.Intf - (map_signature_gen x ~tool_name ~hook ~expect_mismatch_handler - ~input_name:(Some input_name)) + let ast = + match + map_signature_gen x ~tool_name ~hook ~expect_mismatch_handler + ~input_name:(Some input_name) ~embed_errors + with + | Error ast | Ok ast -> ast + in + Intf_or_impl.Intf ast | Impl x -> - Intf_or_impl.Impl - (map_structure_gen x ~tool_name ~hook ~expect_mismatch_handler - ~input_name:(Some input_name)) + let ast = + match + map_structure_gen x ~tool_name ~hook ~expect_mismatch_handler + ~input_name:(Some input_name) ~embed_errors + with + | Error ast | Ok ast -> ast + in + Intf_or_impl.Impl ast let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode ~embed_errors ~output = @@ -967,6 +1058,7 @@ let ast = extract_cookies ast |> process_ast ~input_name ~tool_name ~hook ~expect_mismatch_handler + ~embed_errors in (input_fname, input_version, ast) with exn when embed_errors -> @@ -1040,13 +1132,9 @@ Caml.exit 1) let output_mode = ref Pretty_print - let output = ref None - let kind = ref None - let input = ref None - let embed_errors = ref false let set_input fn = @@ -1185,7 +1273,8 @@ ( "-no-merge", Arg.Set no_merge, " Do not merge context free transformations (better for debugging \ - rewriters)" ); + rewriters). As a result, the context-free transformations are not all \ + applied before all impl and intf." ); ("-cookie", Arg.String set_cookie, "NAME=EXPR Set the cookie NAME to EXPR"); ("--cookie", Arg.String set_cookie, " Same as -cookie"); ] @@ -1329,6 +1418,7 @@ let hook = Context_free.Generated_code_hook.nop in let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in process_ast ast ~input_name ~tool_name ~hook ~expect_mismatch_handler + ~embed_errors:true with exn -> exn_to_extension exn ~kind:(Intf_or_impl.kind ast) in with_output (Some output_fn) ~binary:true ~f:(fun oc -> @@ -1411,7 +1501,5 @@ perform_checks_on_extensions := true let enable_location_check () = perform_locations_check := true - let disable_location_check () = perform_locations_check := false - let map_structure st = map_structure st diff -Nru ppxlib-0.24.0/src/driver.mli ppxlib-0.27.0/src/driver.mli --- ppxlib-0.24.0/src/driver.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/driver.mli 2022-06-14 18:16:33.000000000 +0000 @@ -15,7 +15,16 @@ val get : t -> string -> (expression, 'a -> 'a, 'b) Ast_pattern.t -> 'b option (** [get cookies name pattern] look for a cookie named [name] and parse it - using [pattern]. *) + using [pattern]. Raises if the parsing fails. *) + + val get_res : + t -> + string -> + (expression, 'a -> 'a, 'b) Ast_pattern.t -> + ('b option, Location.Error.t NonEmptyList.t) result + (** [get cookies name pattern] look for a cookie named [name] and parse it + using [pattern], returning a [result] instead of raising when the parsing + fails. *) val set : t -> string -> expression -> unit (** [set cookies name expr] set cookie [name] to [expr]. *) @@ -41,7 +50,6 @@ module Instrument : sig type t - type pos = Before | After val make : (Parsetree.structure -> Parsetree.structure) -> position:pos -> t @@ -252,11 +260,7 @@ (**/**) val map_structure : structure -> structure - val map_signature : signature -> signature - val enable_checks : unit -> unit - val enable_location_check : unit -> unit - val disable_location_check : unit -> unit diff -Nru ppxlib-0.24.0/src/expansion_context.ml ppxlib-0.27.0/src/expansion_context.ml --- ppxlib-0.24.0/src/expansion_context.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/expansion_context.ml 2022-06-14 18:16:33.000000000 +0000 @@ -6,11 +6,8 @@ { tool_name; code_path; input_name } let code_path t = t.code_path - let input_name t = t.input_name - let tool_name t = t.tool_name - let enter_expr t = { t with code_path = Code_path.enter_expr t.code_path } let enter_module ~loc name t = @@ -24,13 +21,9 @@ type t = { extension_point_loc : Location.t; base : Base.t } let make ~extension_point_loc ~base () = { extension_point_loc; base } - let extension_point_loc t = t.extension_point_loc - let code_path t = t.base.code_path - let input_name t = t.base.input_name - let tool_name t = t.base.tool_name let with_loc_and_path f ~ctxt = @@ -45,13 +38,9 @@ { derived_item_loc; base; inline } let derived_item_loc t = t.derived_item_loc - let code_path t = t.base.code_path - let input_name t = t.base.input_name - let tool_name t = t.base.tool_name - let inline t = t.inline let with_loc_and_path f ~ctxt = diff -Nru ppxlib-0.24.0/src/expansion_context.mli ppxlib-0.27.0/src/expansion_context.mli --- ppxlib-0.24.0/src/expansion_context.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/expansion_context.mli 2022-06-14 18:16:33.000000000 +0000 @@ -39,7 +39,6 @@ details. *) val enter_module : loc:Location.t -> string -> t -> t - val enter_value : loc:Location.t -> string -> t -> t end diff -Nru ppxlib-0.24.0/src/extension.ml ppxlib-0.27.0/src/extension.ml --- ppxlib-0.24.0/src/extension.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/extension.ml 2022-06-14 18:16:33.000000000 +0000 @@ -21,25 +21,15 @@ type packed = T : _ t -> packed let class_expr = Class_expr - let class_field = Class_field - let class_type = Class_type - let class_type_field = Class_type_field - let core_type = Core_type - let expression = Expression - let module_expr = Module_expr - let module_type = Module_type - let pattern = Pattern - let signature_item = Signature_item - let structure_item = Structure_item let desc : type a. a t -> string = function @@ -114,27 +104,59 @@ | Ppx_import, type_decl -> get_ppx_import_extension type_decl | _ -> None - let merge_attributes : type a. a t -> a -> attributes -> a = + let node_of_extension : + type a. ?loc:Location.t -> ?x:a -> a t -> extension -> a = + fun ?(loc = Location.none) ?x t -> + let open Ast_builder.Default in + match (t, x) with + | Class_expr, _ -> pcl_extension ~loc + | Class_field, _ -> pcf_extension ~loc + | Class_type_field, _ -> pctf_extension ~loc + | Class_type, _ -> pcty_extension ~loc + | Core_type, _ -> ptyp_extension ~loc + | Expression, _ -> pexp_extension ~loc + | Module_expr, _ -> pmod_extension ~loc + | Module_type, _ -> pmty_extension ~loc + | Pattern, _ -> ppat_extension ~loc + | Signature_item, _ -> fun ext -> psig_extension ~loc ext [] + | Structure_item, _ -> fun ext -> pstr_extension ~loc ext [] + | Ppx_import, Some x -> + fun ext -> + { + x with + ptype_manifest = Some (Ast_builder.Default.ptyp_extension ~loc ext); + } + | Ppx_import, None -> + failwith + "Ppxlib internal error: Item not provided to build an extension node \ + from a Ppx_import context." + + let merge_attributes_res : + type a. + a t -> a -> attributes -> (a, Location.Error.t NonEmptyList.t) result = fun t x attrs -> match t with - | Class_expr -> { x with pcl_attributes = x.pcl_attributes @ attrs } - | Class_field -> { x with pcf_attributes = x.pcf_attributes @ attrs } - | Class_type -> { x with pcty_attributes = x.pcty_attributes @ attrs } - | Class_type_field -> { x with pctf_attributes = x.pctf_attributes @ attrs } - | Core_type -> { x with ptyp_attributes = x.ptyp_attributes @ attrs } - | Expression -> { x with pexp_attributes = x.pexp_attributes @ attrs } - | Module_expr -> { x with pmod_attributes = x.pmod_attributes @ attrs } - | Module_type -> { x with pmty_attributes = x.pmty_attributes @ attrs } - | Pattern -> { x with ppat_attributes = x.ppat_attributes @ attrs } - | Signature_item -> - assert_no_attributes attrs; - x - | Structure_item -> - assert_no_attributes attrs; - x - | Ppx_import -> - assert_no_attributes attrs; - x + | Class_expr -> Ok { x with pcl_attributes = x.pcl_attributes @ attrs } + | Class_field -> Ok { x with pcf_attributes = x.pcf_attributes @ attrs } + | Class_type -> Ok { x with pcty_attributes = x.pcty_attributes @ attrs } + | Class_type_field -> + Ok { x with pctf_attributes = x.pctf_attributes @ attrs } + | Core_type -> Ok { x with ptyp_attributes = x.ptyp_attributes @ attrs } + | Expression -> Ok { x with pexp_attributes = x.pexp_attributes @ attrs } + | Module_expr -> Ok { x with pmod_attributes = x.pmod_attributes @ attrs } + | Module_type -> Ok { x with pmty_attributes = x.pmty_attributes @ attrs } + | Pattern -> Ok { x with ppat_attributes = x.ppat_attributes @ attrs } + | Signature_item -> ( + match attributes_errors attrs with [] -> Ok x | t :: q -> Error (t, q)) + | Structure_item -> ( + match attributes_errors attrs with [] -> Ok x | t :: q -> Error (t, q)) + | Ppx_import -> ( + match attributes_errors attrs with [] -> Ok x | t :: q -> Error (t, q)) + + let merge_attributes : type a. a t -> a -> attributes -> a = + fun t x attrs -> + merge_attributes_res t x attrs + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) end let registrar = @@ -186,29 +208,35 @@ let { txt = name; loc } = fst ext in let name, arg = Name.split_path name in match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name) with - | [] -> None + | [] -> Ok None | _ :: _ :: _ as l -> - Location.raise_errorf ~loc "Multiple match for extensions: %s" - (String.concat ~sep:", " - (List.map l ~f:(fun t -> Name.Pattern.name t.name))) + Error + ( Location.Error.createf ~loc "Multiple match for extensions: %s" + (String.concat ~sep:", " + (List.map l ~f:(fun t -> Name.Pattern.name t.name))), + [] ) | [ t ] -> if (not t.with_arg) && Option.is_some arg then - Location.raise_errorf ~loc - "Extension %s doesn't expect a path argument" name; - let arg = - Option.map arg ~f:(fun s -> - let shift = String.length name + 1 in - let start = loc.loc_start in - { - txt = Longident.parse s; - loc = - { - loc with - loc_start = { start with pos_cnum = start.pos_cnum + shift }; - }; - }) - in - Some (t, arg) + Error + ( Location.Error.createf ~loc + "Extension %s doesn't expect a path argument" name, + [] ) + else + let arg = + Option.map arg ~f:(fun s -> + let shift = String.length name + 1 in + let start = loc.loc_start in + { + txt = Longident.parse s; + loc = + { + loc with + loc_start = + { start with pos_cnum = start.pos_cnum + shift }; + }; + }) + in + Ok (Some (t, arg)) end module Expert = struct @@ -222,11 +250,18 @@ let declare name ctx patt f = declare ~with_arg:false name ctx patt (fun ~arg:_ -> f) - let convert ts ~loc ext = - match find ts ext with - | None -> None + let convert_res ts ~loc ext = + let open Result in + find ts ext >>= fun r -> + match r with + | None -> Ok None | Some ({ payload = Payload_parser (pattern, f); _ }, arg) -> - Some (Ast_pattern.parse pattern loc (snd ext) (f ~arg)) + Ast_pattern.parse_res pattern loc (snd ext) (f ~arg) >>| fun payload -> + Some payload + + let convert ts ~loc ext = + convert_res ts ~loc ext + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) end module M = Make (struct @@ -239,23 +274,37 @@ module For_context = struct type 'a t = ('a, 'a expander_result) M.t - let convert ts ~ctxt ext = + let convert_res ts ~ctxt ext = let loc = Expansion_context.Extension.extension_point_loc ctxt in - match M.find ts ext with - | None -> None + let open Result in + M.find ts ext >>= fun found -> + match found with + | None -> Ok None | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> ( - match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with + Ast_pattern.parse_res pattern loc (snd ext) (f ~ctxt ~arg) + >>| fun payload -> + match payload with | Simple x -> Some x | Inline _ -> failwith "Extension.convert") - let convert_inline ts ~ctxt ext = + let convert ts ~ctxt ext = + convert_res ts ~ctxt ext + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + + let convert_inline_res ts ~ctxt ext = let loc = Expansion_context.Extension.extension_point_loc ctxt in - match M.find ts ext with - | None -> None + let open Result in + M.find ts ext >>= fun found -> + match found with + | None -> Ok None | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> ( - match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with - | Simple x -> Some [ x ] - | Inline l -> Some l) + Ast_pattern.parse_res pattern loc (snd ext) (f ~ctxt ~arg) + >>| fun payload -> + match payload with Simple x -> Some [ x ] | Inline l -> Some l) + + let convert_inline ts ~ctxt ext = + convert_inline_res ts ~ctxt ext + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) end type t = T : _ For_context.t -> t @@ -281,72 +330,143 @@ | Eq -> t :: filter_by_context context rest | Ne -> filter_by_context context rest) -let fail ctx (name, _) = +let unhandled_extension_error ctx (name, _) = if not - (Name.Whitelisted.is_whitelisted ~kind:`Extension name.txt + (Name.Allowlisted.is_allowlisted ~kind:`Extension name.txt || Name.ignore_checks name.txt) then - Name.Registrar.raise_errorf registrar (Context.T ctx) - "Extension `%s' was not translated" name + [ + Name.Registrar.Error.createf registrar (Context.T ctx) + "Extension `%s' was not translated" name; + ] + else [] + +let collect_unhandled_extension_errors = + object + inherit [Location.Error.t list] Ast_traverse.fold as super + + method! extension (name, _) acc = + acc + @ [ + Location.Error.createf ~loc:name.loc + "extension not expected here, Ppxlib.Extension needs updating!"; + ] + + method! core_type_desc x acc = + match x with + | Ptyp_extension ext -> acc @ unhandled_extension_error Core_type ext + | x -> super#core_type_desc x acc + + method! pattern_desc x acc = + match x with + | Ppat_extension ext -> acc @ unhandled_extension_error Pattern ext + | x -> super#pattern_desc x acc + + method! expression_desc x acc = + match x with + | Pexp_extension ext -> acc @ unhandled_extension_error Expression ext + | x -> super#expression_desc x acc + + method! class_type_desc x acc = + match x with + | Pcty_extension ext -> acc @ unhandled_extension_error Class_type ext + | x -> super#class_type_desc x acc + + method! class_type_field_desc x acc = + match x with + | Pctf_extension ext -> + acc @ unhandled_extension_error Class_type_field ext + | x -> super#class_type_field_desc x acc + + method! class_expr_desc x acc = + match x with + | Pcl_extension ext -> acc @ unhandled_extension_error Class_expr ext + | x -> super#class_expr_desc x acc + + method! class_field_desc x acc = + match x with + | Pcf_extension ext -> acc @ unhandled_extension_error Class_field ext + | x -> super#class_field_desc x acc + + method! module_type_desc x acc = + match x with + | Pmty_extension ext -> acc @ unhandled_extension_error Module_type ext + | x -> super#module_type_desc x acc + + method! signature_item_desc x acc = + match x with + | Psig_extension (ext, _) -> + acc @ unhandled_extension_error Signature_item ext + | x -> super#signature_item_desc x acc + + method! module_expr_desc x acc = + match x with + | Pmod_extension ext -> acc @ unhandled_extension_error Module_expr ext + | x -> super#module_expr_desc x acc + + method! structure_item_desc x acc = + match x with + | Pstr_extension (ext, _) -> + acc @ unhandled_extension_error Structure_item ext + | x -> super#structure_item_desc x acc + end + +let error_list_to_exception = function + | [] -> () + | err :: _ -> Location.Error.raise err let check_unused = object - inherit Ast_traverse.iter as super + inherit Ast_traverse.iter method! extension (name, _) = Location.raise_errorf ~loc:name.loc "extension not expected here, Ppxlib.Extension needs updating!" - method! core_type_desc = - function - | Ptyp_extension ext -> fail Core_type ext | x -> super#core_type_desc x - - method! pattern_desc = - function - | Ppat_extension ext -> fail Pattern ext | x -> super#pattern_desc x - - method! expression_desc = - function - | Pexp_extension ext -> fail Expression ext | x -> super#expression_desc x - - method! class_type_desc = - function - | Pcty_extension ext -> fail Class_type ext | x -> super#class_type_desc x - - method! class_type_field_desc = - function - | Pctf_extension ext -> fail Class_type_field ext - | x -> super#class_type_field_desc x - - method! class_expr_desc = - function - | Pcl_extension ext -> fail Class_expr ext | x -> super#class_expr_desc x - - method! class_field_desc = - function - | Pcf_extension ext -> fail Class_field ext - | x -> super#class_field_desc x - - method! module_type_desc = - function - | Pmty_extension ext -> fail Module_type ext - | x -> super#module_type_desc x - - method! signature_item_desc = - function - | Psig_extension (ext, _) -> fail Signature_item ext - | x -> super#signature_item_desc x - - method! module_expr_desc = - function - | Pmod_extension ext -> fail Module_expr ext - | x -> super#module_expr_desc x - - method! structure_item_desc = - function - | Pstr_extension (ext, _) -> fail Structure_item ext - | x -> super#structure_item_desc x + method! core_type_desc x = + collect_unhandled_extension_errors#core_type_desc x [] + |> error_list_to_exception + + method! pattern_desc x = + collect_unhandled_extension_errors#pattern_desc x [] + |> error_list_to_exception + + method! expression_desc x = + collect_unhandled_extension_errors#expression_desc x [] + |> error_list_to_exception + + method! class_type_desc x = + collect_unhandled_extension_errors#class_type_desc x [] + |> error_list_to_exception + + method! class_type_field_desc x = + collect_unhandled_extension_errors#class_type_field_desc x [] + |> error_list_to_exception + + method! class_expr_desc x = + collect_unhandled_extension_errors#class_expr_desc x [] + |> error_list_to_exception + + method! class_field_desc x = + collect_unhandled_extension_errors#class_field_desc x [] + |> error_list_to_exception + + method! module_type_desc x = + collect_unhandled_extension_errors#module_type_desc x [] + |> error_list_to_exception + + method! signature_item_desc x = + collect_unhandled_extension_errors#signature_item_desc x [] + |> error_list_to_exception + + method! module_expr_desc x = + collect_unhandled_extension_errors#module_expr_desc x [] + |> error_list_to_exception + + method! structure_item_desc x = + collect_unhandled_extension_errors#structure_item_desc x [] + |> error_list_to_exception end module V3 = struct @@ -396,6 +516,5 @@ type nonrec t = t let declare = declare - let declare_inline = declare_inline end diff -Nru ppxlib-0.24.0/src/extension.mli ppxlib-0.27.0/src/extension.mli --- ppxlib-0.24.0/src/extension.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/extension.mli 2022-06-14 18:16:33.000000000 +0000 @@ -19,32 +19,32 @@ (** For ppx_import compat only, please do not use *) val class_expr : class_expr t - val class_field : class_field t - val class_type : class_type t - val class_type_field : class_type_field t - val core_type : core_type t - val expression : expression t - val module_expr : module_expr t - val module_type : module_type t - val pattern : pattern t - val signature_item : signature_item t - val structure_item : structure_item t - val eq : 'a t -> 'b t -> ('a, 'b) equality - val get_extension : 'a t -> 'a -> (extension * attributes) option + val node_of_extension : ?loc:Location.t -> ?x:'a -> 'a t -> extension -> 'a + (** [node_of_extension ctx ext] turns an extension node into an AST node of + the same type as [ctx]. By default, the location of the node is + {!Location.none}. + + Only for the special case of [Ppx_import], a value of type + {!type_declaration} has to be passed as the named argument [x], the + extension node will be added as the {!ptype_manifest} of [x]. *) + val merge_attributes : 'a t -> 'a -> attributes -> 'a + + val merge_attributes_res : + 'a t -> 'a -> attributes -> ('a, Location.Error.t NonEmptyList.t) result end type t @@ -108,9 +108,21 @@ type 'a t + val convert_res : + 'a t list -> + ctxt:Expansion_context.Extension.t -> + extension -> + ('a option, Location.Error.t NonEmptyList.t) result + val convert : 'a t list -> ctxt:Expansion_context.Extension.t -> extension -> 'a option + val convert_inline_res : + 'a t list -> + ctxt:Expansion_context.Extension.t -> + extension -> + ('a list option, Location.Error.t NonEmptyList.t) result + val convert_inline : 'a t list -> ctxt:Expansion_context.Extension.t -> @@ -147,10 +159,17 @@ (arg:Longident.t Loc.t option -> 'a) -> ('context, 'b) t + val convert_res : + (_, 'a) t list -> + loc:Location.t -> + extension -> + ('a option, Location.Error.t NonEmptyList.t) result + val convert : (_, 'a) t list -> loc:Location.t -> extension -> 'a option end val check_unused : Ast_traverse.iter +val collect_unhandled_extension_errors : Location.Error.t list Ast_traverse.fold module V2 : sig type nonrec t = t diff -Nru ppxlib-0.24.0/src/file_path.mli ppxlib-0.27.0/src/file_path.mli --- ppxlib-0.24.0/src/file_path.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/file_path.mli 2022-06-14 18:16:33.000000000 +0000 @@ -3,7 +3,5 @@ (** Return the path used as root in a file *) val get_default_path : Location.t -> string - val get_default_path_str : structure -> string - val get_default_path_sig : signature -> string diff -Nru ppxlib-0.24.0/src/gen/gen_ast_builder.ml ppxlib-0.27.0/src/gen/gen_ast_builder.ml --- ppxlib-0.24.0/src/gen/gen_ast_builder.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/gen/gen_ast_builder.ml 2022-06-14 18:16:33.000000000 +0000 @@ -214,7 +214,6 @@ dump "ast_builder_generated" Pprintast.structure st ~ext:".ml" let args = [] - let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = diff -Nru ppxlib-0.24.0/src/gen/gen_ast_pattern.ml ppxlib-0.27.0/src/gen/gen_ast_pattern.ml --- ppxlib-0.24.0/src/gen/gen_ast_pattern.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/gen/gen_ast_pattern.ml 2022-06-14 18:16:33.000000000 +0000 @@ -237,7 +237,6 @@ dump "ast_pattern_generated" Pprintast.structure st ~ext:".ml" let args = [] - let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = diff -Nru ppxlib-0.24.0/src/gen/import.ml ppxlib-0.27.0/src/gen/import.ml --- ppxlib-0.24.0/src/gen/import.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/gen/import.ml 2022-06-14 18:16:33.000000000 +0000 @@ -12,7 +12,6 @@ module Loc = struct let mk x = { Location.loc; txt = x } - let lident x = mk (Longident.parse x) [@@warning "-3"] end @@ -21,7 +20,6 @@ module Array = Stdppx.Array let evar v = Exp.ident (Loc.lident v) - let pvar v = Pat.var (Loc.mk v) let common_prefix l = @@ -73,7 +71,6 @@ | Lapply _ -> assert false let fqn_longident path id : Longident.t = fqn_longident' path id - let is_loc = function Lident "loc" -> true | _ -> false let get_types ~filename = @@ -81,7 +78,6 @@ let map = object inherit Ast.map as super - inherit Ppxlib_traverse_builtins.map method! core_type_desc = @@ -120,13 +116,9 @@ (* Small metaquotation system *) module M = struct let parse f fmt = Format.kasprintf (fun s -> f (Lexing.from_string s)) fmt - let expr fmt = parse Parse.expression fmt - let patt fmt = parse Parse.pattern fmt - let ctyp fmt = parse Parse.core_type fmt - let str fmt = parse Parse.implementation fmt let stri fmt = @@ -141,11 +133,8 @@ (* Antiquotations *) module A = struct let expr = Pprintast.expression - let patt = Pprintast.pattern - let ctyp = Pprintast.core_type - let str = Pprintast.structure let id ppf x = diff -Nru ppxlib-0.24.0/src/ignore_unused_warning.mli ppxlib-0.27.0/src/ignore_unused_warning.mli --- ppxlib-0.24.0/src/ignore_unused_warning.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/ignore_unused_warning.mli 2022-06-14 18:16:33.000000000 +0000 @@ -1,3 +1,2 @@ val add_dummy_user_for_values : Ast_traverse.map - val binds_module_names : bool Ast_traverse.fold diff -Nru ppxlib-0.24.0/src/location_check.ml ppxlib-0.27.0/src/location_check.ml --- ppxlib-0.24.0/src/location_check.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/location_check.ml 2022-06-14 18:16:33.000000000 +0000 @@ -4,9 +4,7 @@ type t val empty : t - val insert : node_name:string -> Location.t -> t -> t - val union : t -> t -> t val covered_by : t -> loc:Location.t -> bool @@ -134,7 +132,6 @@ Location.compare_pos loc.loc_end attr.attr_loc.loc_end >= 0) let file : string option ref = ref None - let same_file_so_far = ref true let stayed_in_the_same_file fname = diff -Nru ppxlib-0.24.0/src/location.ml ppxlib-0.27.0/src/location.ml --- ppxlib-0.24.0/src/location.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/location.ml 2022-06-14 18:16:33.000000000 +0000 @@ -24,7 +24,6 @@ { pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } let raise_errorf ?loc fmt = L.raise_errorf ?loc fmt - let report_exception = L.report_exception let of_lexbuf (lexbuf : Lexing.lexbuf) = @@ -56,7 +55,6 @@ | n -> n let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2 - let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2 let compare loc1 loc2 = @@ -70,6 +68,11 @@ let createf ~loc fmt = Format.kasprintf (fun str -> make ~loc ~sub:[] str) fmt end +let error_extensionf ~loc fmt = + Format.kasprintf + (fun str -> Error.to_extension @@ Error.make ~loc ~sub:[] str) + fmt + exception Error = L.Error let () = diff -Nru ppxlib-0.24.0/src/location.mli ppxlib-0.27.0/src/location.mli --- ppxlib-0.24.0/src/location.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/location.mli 2022-06-14 18:16:33.000000000 +0000 @@ -25,8 +25,8 @@ named file. *) val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a -(** Raise a located error. The exception is caught by driver and handled - appropriately *) +(** Raise a located error. Should be avoided as much as possible, in favor of + {!error_extensionf}. *) val of_lexbuf : Lexing.lexbuf -> t (** Return the location corresponding to the last matched regular expression *) @@ -40,16 +40,12 @@ type nonrec 'a loc = 'a loc = { txt : 'a; loc : t } val compare_pos : Lexing.position -> Lexing.position -> int - val min_pos : Lexing.position -> Lexing.position -> Lexing.position - val max_pos : Lexing.position -> Lexing.position -> Lexing.position - val compare : t -> t -> int module Error : sig type location = t - type t val make : loc:location -> string -> sub:(location * string) list -> t @@ -58,7 +54,6 @@ loc:location -> ('a, Caml.Format.formatter, unit, t) format4 -> 'a val message : t -> string - val set_message : t -> string -> t val register_error_of_exn : (exn -> t option) -> unit @@ -84,4 +79,9 @@ end with type location := t +val error_extensionf : + loc:t -> ('a, Format.formatter, unit, extension) format4 -> 'a +(** Returns an error extension node. When encountered in the AST, the compiler + recognizes it and displays the error properly. *) + exception Error of Error.t diff -Nru ppxlib-0.24.0/src/loc.ml ppxlib-0.27.0/src/loc.ml --- ppxlib-0.24.0/src/loc.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/loc.ml 2022-06-14 18:16:33.000000000 +0000 @@ -3,9 +3,6 @@ type 'a t = 'a loc = { txt : 'a; loc : Location.t } let txt t = t.txt - let loc t = t.loc - let make ~loc txt = { loc; txt } - let map t ~f = { t with txt = f t.txt } diff -Nru ppxlib-0.24.0/src/loc.mli ppxlib-0.27.0/src/loc.mli --- ppxlib-0.24.0/src/loc.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/loc.mli 2022-06-14 18:16:33.000000000 +0000 @@ -5,9 +5,6 @@ type 'a t = 'a loc = { txt : 'a; loc : Location.t } val txt : 'a t -> 'a - val loc : _ t -> Location.t - val make : loc:Location.t -> 'a -> 'a t - val map : 'a t -> f:('a -> 'b) -> 'b t diff -Nru ppxlib-0.24.0/src/longident.mli ppxlib-0.27.0/src/longident.mli --- ppxlib-0.24.0/src/longident.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/longident.mli 2022-06-14 18:16:33.000000000 +0000 @@ -5,11 +5,8 @@ type t = longident = Lident of string | Ldot of t * string | Lapply of t * t val compare : t -> t -> int - val sexp_of_t : t -> Sexp.t - val flatten_exn : t -> string list - val last_exn : t -> string val parse : string -> t @@ -20,5 +17,4 @@ val name : t -> string module Map : Map.S with type key = t - module Set : Set.S with type elt = t diff -Nru ppxlib-0.24.0/src/merlin_helpers.ml ppxlib-0.27.0/src/merlin_helpers.ml --- ppxlib-0.24.0/src/merlin_helpers.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/merlin_helpers.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1,9 +1,7 @@ open! Import let mk_attr_noloc txt = Ast_helper.Attr.mk Location.{ txt; loc = none } - let hide_attribute : attribute = mk_attr_noloc "merlin.hide" (PStr []) - let focus_attribute : attribute = mk_attr_noloc "merlin.focus" (PStr []) let hide_pattern ({ ppat_attributes; _ } as p) = diff -Nru ppxlib-0.24.0/src/merlin_helpers.mli ppxlib-0.27.0/src/merlin_helpers.mli --- ppxlib-0.24.0/src/merlin_helpers.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/merlin_helpers.mli 2022-06-14 18:16:33.000000000 +0000 @@ -20,9 +20,6 @@ specific pieces of AST. *) val hide_pattern : pattern -> pattern - val focus_pattern : pattern -> pattern - val hide_expression : expression -> expression - val focus_expression : expression -> expression diff -Nru ppxlib-0.24.0/src/name.ml ppxlib-0.27.0/src/name.ml --- ppxlib-0.24.0/src/name.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/name.ml 2022-06-14 18:16:33.000000000 +0000 @@ -41,7 +41,6 @@ { name; dot_suffixes = String.Set.of_list (dot_suffixes name) } let name t = t.name - let matches t matched = String.Set.mem matched t.dot_suffixes end @@ -50,8 +49,8 @@ | None -> None | Some i -> Some (String.sub name ~pos:0 ~len:i) -module Whitelisted = struct - (* White list the following attributes, as well as all their dot suffixes. +module Allowlisted = struct + (* Allow list the following attributes, as well as all their dot suffixes. Since these attributes are interpreted by the compiler itself, we cannot check at the level of a ppx rewriter that they have been properly interpreted, so @@ -93,9 +92,11 @@ "ocaml.warn_on_literal_pattern"; "ocaml.warnerror"; "ocaml.warning"; + "ocaml.toplevel_printer" (*Interpreted by the toplevel/utop*); + "toplevel_printer" (*Interpreted by the toplevel/utop*); ] - (* White list the following extensions. + (* Allow list the following extensions. Since these extensions are interpreted by the compiler itself, we cannot check at the level of a ppx rewriter that they have been properly interpreted, so @@ -103,29 +104,22 @@ *) let extensions = create_set [ "ocaml.error"; "ocaml.extension_constructor" ] - let is_whitelisted ~kind name = + let is_allowlisted ~kind name = match kind with | `Attribute -> String.Set.mem name attributes | `Extension -> String.Set.mem name extensions let get_attribute_list () = String.Set.elements attributes - let get_extension_list () = String.Set.elements extensions end module Reserved_namespaces = struct let tbl : (string, unit) Hashtbl.t = Hashtbl.create 16 - let reserve ns = Hashtbl.add_exn tbl ~key:ns ~data:() - let () = reserve "merlin" - let () = reserve "reason" - let () = reserve "refmt" - let () = reserve "metaocaml" - let () = reserve "ocamlformat" let is_in_reserved_namespaces name = @@ -136,8 +130,8 @@ let check_not_reserved ~kind name = let kind, list = match kind with - | `Attribute -> ("attribute", Whitelisted.attributes) - | `Extension -> ("extension", Whitelisted.extensions) + | `Attribute -> ("attribute", Allowlisted.attributes) + | `Extension -> ("extension", Allowlisted.extensions) in if String.Set.mem name list then Printf.ksprintf failwith @@ -157,7 +151,6 @@ module Registrar = struct type element = { fully_qualified_name : string; declared_at : Caller_id.t } - type all_for_context = { mutable all : element String.Map.t } type 'a t = { @@ -215,12 +208,12 @@ fold_dot_suffixes name ~init:all.all ~f:(fun name acc -> String.Map.add name t acc) - let spellcheck t context ?(white_list = []) name = + let spellcheck t context ?(allowlist = []) name = let all = let all = get_all_for_context t context in String.Map.fold (fun key _ acc -> key :: acc) all.all [] in - match Spellcheck.spellcheck (all @ white_list) name with + match Spellcheck.spellcheck (all @ allowlist) name with | Some _ as x -> x | None -> ( let other_contexts = @@ -267,13 +260,23 @@ Format.fprintf ppf ",@ ")) others pp_text last current_context)) - (* TODO: hint spelling errors regarding reserved namespaces names and white - listed names instead of taking an optional [white_list] parameter. *) - let raise_errorf t context ?white_list fmt (name : string Loc.t) = - Printf.ksprintf - (fun msg -> - match spellcheck t context name.txt ?white_list with - | None -> Location.raise_errorf ~loc:name.loc "%s" msg - | Some s -> Location.raise_errorf ~loc:name.loc "%s.\n%s" msg s) - fmt name.txt + module Error = struct + (* TODO: hint spelling errors regarding reserved namespaces names and allowlisted + names instead of taking an optional [allowlist] parameter. *) + let createf t context ?allowlist fmt (name : string Loc.t) = + Printf.ksprintf + (fun msg -> + match spellcheck t context name.txt ?allowlist with + | None -> Location.Error.createf ~loc:name.loc "%s" msg + | Some s -> Location.Error.createf ~loc:name.loc "%s.\n%s" msg s) + fmt name.txt + + let raise_errorf t context ?allowlist fmt (name : string Loc.t) = + Location.Error.raise @@ createf t context ?allowlist fmt name + + let error_extensionf t context ?allowlist fmt (name : string Loc.t) = + Location.Error.to_extension @@ createf t context ?allowlist fmt name + end + + let raise_errorf = Error.raise_errorf end diff -Nru ppxlib-0.24.0/src/name.mli ppxlib-0.27.0/src/name.mli --- ppxlib-0.24.0/src/name.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/name.mli 2022-06-14 18:16:33.000000000 +0000 @@ -52,23 +52,47 @@ val check_collisions : 'context t -> 'context -> string -> unit val spellcheck : - 'context t -> 'context -> ?white_list:string list -> string -> string option + 'context t -> 'context -> ?allowlist:string list -> string -> string option + + module Error : sig + val createf : + 'context t -> + 'context -> + ?allowlist:string list -> + (string -> Location.Error.t, unit, string, Location.Error.t) format4 -> + string Loc.t -> + Location.Error.t + + val raise_errorf : + 'context t -> + 'context -> + ?allowlist:string list -> + (string -> Location.Error.t, unit, string, Location.Error.t) format4 -> + string Loc.t -> + 'a + + val error_extensionf : + 'context t -> + 'context -> + ?allowlist:string list -> + (string -> Location.Error.t, unit, string, Location.Error.t) format4 -> + string Loc.t -> + extension + end val raise_errorf : 'context t -> 'context -> - ?white_list:string list -> - (string -> 'a, unit, string, 'c) format4 -> + ?allowlist:string list -> + (string -> Location.Error.t, unit, string, Location.Error.t) format4 -> string Loc.t -> 'a end -module Whitelisted : sig +module Allowlisted : sig val get_attribute_list : unit -> string list - val get_extension_list : unit -> string list - - val is_whitelisted : kind:[ `Attribute | `Extension ] -> string -> bool + val is_allowlisted : kind:[ `Attribute | `Extension ] -> string -> bool end module Reserved_namespaces : sig diff -Nru ppxlib-0.24.0/src/options.ml ppxlib-0.27.0/src/options.ml --- ppxlib-0.24.0/src/options.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/options.ml 2022-06-14 18:16:33.000000000 +0000 @@ -5,9 +5,6 @@ them externally to make it easier to use non ppxlib based rewriters with ppxlib *) let perform_checks_on_extensions = false - let perform_locations_check = false - let fail_on_duplicate_derivers = false - let diff_command = None diff -Nru ppxlib-0.24.0/src/quoter.ml ppxlib-0.27.0/src/quoter.ml --- ppxlib-0.24.0/src/quoter.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/quoter.ml 2022-06-14 18:16:33.000000000 +0000 @@ -18,16 +18,25 @@ let loc = e.pexp_loc in let (module Ast) = Ast_builder.make loc in let name = "__" ^ Int.to_string t.next_id in + let binding_expr, quoted_expr = + match e with + (* Optimize identifier quoting by avoiding closure. + See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *) + | { pexp_desc = Pexp_ident _; _ } -> (e, Ast.evar name) + | _ -> + let binding_expr = + Ast.pexp_fun Nolabel None + (let unit = Ast_builder.Default.Located.lident ~loc "()" in + Ast.ppat_construct unit None) + e + in + let quoted_expr = Ast.eapply (Ast.evar name) [ Ast.eunit ] in + (binding_expr, quoted_expr) + in let binding = let pat = Ast.pvar name in - let expr = - Ast.pexp_fun Nolabel None - (let unit = Ast_builder.Default.Located.lident ~loc "()" in - Ast.ppat_construct unit None) - e - in - Ast.value_binding ~pat ~expr + Ast.value_binding ~pat ~expr:binding_expr in t.bindings <- binding :: t.bindings; t.next_id <- t.next_id + 1; - Ast.evar name + quoted_expr diff -Nru ppxlib-0.24.0/src/reconcile.ml ppxlib-0.27.0/src/reconcile.ml --- ppxlib-0.24.0/src/reconcile.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/reconcile.ml 2022-06-14 18:16:33.000000000 +0000 @@ -145,7 +145,6 @@ "(* -----{ GENERATED CODE END }------------------------------------- *)" type mode = Using_line_directives | Delimiting_generated_blocks - type target = Output of mode | Corrected let skip_blank_eol contents (pos : Lexing.position) = diff -Nru ppxlib-0.24.0/src/reconcile.mli ppxlib-0.27.0/src/reconcile.mli --- ppxlib-0.24.0/src/reconcile.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/reconcile.mli 2022-06-14 18:16:33.000000000 +0000 @@ -23,7 +23,6 @@ end type mode = Using_line_directives | Delimiting_generated_blocks - type target = Output of mode | Corrected val reconcile : diff -Nru ppxlib-0.24.0/src/utils.ml ppxlib-0.27.0/src/utils.ml --- ppxlib-0.24.0/src/utils.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/utils.ml 2022-06-14 18:16:33.000000000 +0000 @@ -14,7 +14,6 @@ else None let describe = function Impl -> "implementation" | Intf -> "interface" - let equal : t -> t -> bool = Poly.equal end @@ -54,7 +53,6 @@ | System_error of Location.Error.t * input_version type input_source = Stdin | File of string - type input_kind = Possibly_source of Kind.t * string | Necessarily_binary let read_error_to_string (error : read_error) = @@ -191,7 +189,6 @@ module Read_bin = struct type ast = Intf of signature | Impl of structure - type t = { ast : ast; input_name : string } let read_binary fn = @@ -208,7 +205,6 @@ | Error e -> Error (read_error_to_string e) let get_ast t = t.ast - let get_input_name t = t.input_name end end diff -Nru ppxlib-0.24.0/src/utils.mli ppxlib-0.27.0/src/utils.mli --- ppxlib-0.24.0/src/utils.mli 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/src/utils.mli 2022-06-14 18:16:33.000000000 +0000 @@ -6,9 +6,7 @@ type t = Intf | Impl val of_filename : string -> t option - val describe : t -> string - val equal : t -> t -> bool end @@ -16,9 +14,7 @@ type t = Intf of signature | Impl of structure val map : t -> Ast_traverse.map -> t - val map_with_context : t -> 'a Ast_traverse.map_with_context -> 'a -> t - val kind : t -> Kind.t end @@ -40,22 +36,17 @@ | System_error of Location.Error.t * input_version type input_source = Stdin | File of string - type input_kind = Possibly_source of Kind.t * string | Necessarily_binary val read : input_source -> input_kind:input_kind -> (t, read_error) result - val write : out_channel -> t -> add_ppx_context:bool -> unit module Read_bin : sig type ast = Intf of signature | Impl of structure - type t val read_binary : string -> (t, string) result - val get_ast : t -> ast - val get_input_name : t -> string end end diff -Nru ppxlib-0.24.0/stdppx/stdppx.ml ppxlib-0.27.0/stdppx/stdppx.ml --- ppxlib-0.24.0/stdppx/stdppx.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/stdppx/stdppx.ml 2022-06-14 18:16:33.000000000 +0000 @@ -9,50 +9,31 @@ type t val compare : t -> t -> int - val equal : t -> t -> bool - val ( = ) : t -> t -> bool - val ( < ) : t -> t -> bool - val ( > ) : t -> t -> bool - val ( <> ) : t -> t -> bool - val ( <= ) : t -> t -> bool - val ( >= ) : t -> t -> bool - val min : t -> t -> t - val max : t -> t -> t end module Poly = struct let compare = compare - let equal = ( = ) - let ( = ) = ( = ) - let ( < ) = ( < ) - let ( > ) = ( > ) - let ( <> ) = ( <> ) - let ( <= ) = ( <= ) - let ( >= ) = ( >= ) - let min = min - let max = max end include (Poly : Comparisons with type t := int) - module Array = Array module Bool = struct @@ -72,7 +53,6 @@ module Char = struct include Char - include (Poly : Comparisons with type t := char) end @@ -174,21 +154,22 @@ module Int = struct let max_int = max_int - let to_string = string_of_int include (Poly : Comparisons with type t := int) end +module Either = struct + type ('a, 'b) t = Left of 'a | Right of 'b +end + module List = struct include List include struct (* shadow non-tail-recursive functions *) let merge = `not_tail_recursive - let remove_assoc = `not_tail_recursive - let remove_assq = `not_tail_recursive let rev_mapi list ~f = @@ -203,14 +184,12 @@ fold_left2 (rev list1) (rev list2) ~init ~f:(fun acc x y -> f x y acc) let map list ~f = rev (rev_map list ~f) - let mapi list ~f = rev (rev_mapi list ~f) let fold_right list ~init ~f = fold_left (List.rev list) ~init ~f:(fun acc x -> f x acc) let append x y = rev_append (rev x) y - let concat list = fold_right list ~init:[] ~f:append let rev_combine list1 list2 = @@ -226,6 +205,16 @@ rev (fold_left2 list1 list2 ~init:[] ~f:(fun acc x y -> f x y :: acc)) end + let partition_map p l = + let rec part left right = function + | [] -> (rev left, rev right) + | x :: l -> ( + match p x with + | Either.Left v -> part (v :: left) right l + | Either.Right v -> part left (v :: right) l) + in + part [] [] l + let init ~len ~f = let rec loop ~len ~pos ~f ~acc = if pos >= len then List.rev acc @@ -240,9 +229,7 @@ match option with None -> tail | Some head -> head :: tail) let filter_opt list = rev (rev_filter_opt list) - let filter_map list ~f = rev_filter_opt (rev_map list ~f) - let concat_map list ~f = concat (map list ~f) let rec find_map list ~f = @@ -292,12 +279,28 @@ module Option = struct let is_some = function None -> false | Some _ -> true - let iter t ~f = match t with None -> () | Some x -> f x - let map t ~f = match t with None -> None | Some x -> Some (f x) - let value t ~default = match t with None -> default | Some x -> x + let to_list t = match t with None -> [] | Some x -> [ x ] +end + +module Result = struct + let bind t ~f = match t with Ok a -> f a | Error e -> Error e + let map t ~f = match t with Ok a -> Ok (f a) | Error e -> Error e + let map_error t ~f = match t with Ok a -> Ok (f a) | Error e -> Error e + let ( >>= ) t f = bind t ~f + let ( >>| ) t f = map t ~f + let handle_error t ~f = match t with Ok a -> a | Error e -> f e +end + +module NonEmptyList = struct + type 'a t = 'a * 'a list + + let ( @ ) (t1, q1) (t2, q2) = (t1, q1 @ (t2 :: q2)) + let hd = fst + let to_list (t, q) = t :: q + let map ~f (t, q) = (f t, List.map ~f q) end module Out_channel = struct @@ -321,13 +324,9 @@ include String let is_empty (t : t) = length t = 0 - let prefix t len = sub t ~pos:0 ~len - let suffix t len = sub t ~pos:(length t - len) ~len - let drop_prefix t len = sub t ~pos:len ~len:(length t - len) - let drop_suffix t len = sub t ~pos:0 ~len:(length t - len) let is_prefix t ~prefix = @@ -383,11 +382,8 @@ Some (sub t ~pos:0 ~len:i, sub t ~pos:(i + 1) ~len:(length t - i - 1)) let capitalize_ascii = Stdlib.String.capitalize_ascii - let lowercase_ascii = Stdlib.String.lowercase_ascii - let uncapitalize_ascii = Stdlib.String.uncapitalize_ascii - let split_on_char t ~sep = Stdlib.String.split_on_char sep t include (Poly : Comparisons with type t := string) @@ -403,7 +399,5 @@ end let ( @ ) = List.append - let output oc bytes ~pos ~len = output oc bytes pos len - let output_substring oc string ~pos ~len = output_substring oc string pos len diff -Nru ppxlib-0.24.0/test/code_path/dune ppxlib-0.27.0/test/code_path/dune --- ppxlib-0.24.0/test/code_path/dune 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/code_path/dune 2022-06-14 18:16:33.000000000 +0000 @@ -1,7 +1,7 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} "4.08.0")) + (>= %{ocaml_version} "4.10.0")) (deps (:test test.ml) (package ppxlib)) diff -Nru ppxlib-0.24.0/test/code_path/test.ml ppxlib-0.27.0/test/code_path/test.ml --- ppxlib-0.24.0/test/code_path/test.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/code_path/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1,7 +1,19 @@ #require "base";; +open Base open Ppxlib +let sexp_of_code_path code_path = + Sexp.message + "code_path" + [ "main_module_name", sexp_of_string (Code_path.main_module_name code_path) + ; "submodule_path", sexp_of_list sexp_of_string (Code_path.submodule_path code_path) + ; "enclosing_module", sexp_of_string (Code_path.enclosing_module code_path) + ; "enclosing_value", sexp_of_option sexp_of_string (Code_path.enclosing_value code_path) + ; "value", sexp_of_option sexp_of_string (Code_path.value code_path) + ; "fully_qualified_path", sexp_of_string (Code_path.fully_qualified_path code_path) + ] + let () = Driver.register_transformation "test" ~extensions:[ @@ -12,9 +24,10 @@ let loc = Expansion_context.Extension.extension_point_loc ctxt in let code_path = Expansion_context.Extension.code_path ctxt in Ast_builder.Default.estring ~loc - (Code_path.fully_qualified_path code_path)) + (Sexp.to_string (sexp_of_code_path code_path))) ] [%%expect{| +val sexp_of_code_path : Code_path.t -> Sexp.t = |}] let s = @@ -38,7 +51,8 @@ in A.A'.a ;; [%%expect{| -val s : string = "Test.s" +val s : string = + "(code_path(main_module_name Test)(submodule_path())(enclosing_module C')(enclosing_value(c))(value(s))(fully_qualified_path Test.s))" |}] let module M = struct @@ -47,5 +61,39 @@ in M.m [%%expect{| -- : string = "Test" +- : string = +"(code_path(main_module_name Test)(submodule_path())(enclosing_module M)(enclosing_value(m))(value())(fully_qualified_path Test))" +|}] + +module Outer = struct + module Inner = struct + let code_path = [%code_path] + end +end +let _ = Outer.Inner.code_path +[%%expect{| +module Outer : sig module Inner : sig val code_path : string end end +- : string = +"(code_path(main_module_name Test)(submodule_path(Outer Inner))(enclosing_module Inner)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test.Outer.Inner.code_path))" +|}] + +module Functor() = struct + let code_path = ref "" + module _ = struct + let x = + let module First_class = struct + code_path := [%code_path] + end in + let module _ = First_class in + () + ;; + + ignore x + end +end +let _ = let module M = Functor() in !M.code_path +[%%expect{| +module Functor : functor () -> sig val code_path : string ref end +- : string = +"(code_path(main_module_name Test)(submodule_path(Functor _))(enclosing_module First_class)(enclosing_value(x))(value(x))(fully_qualified_path Test.Functor._.x))" |}] diff -Nru ppxlib-0.24.0/test/driver/attributes/test.ml ppxlib-0.27.0/test/driver/attributes/test.ml --- ppxlib-0.24.0/test/driver/attributes/test.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/attributes/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -15,7 +15,7 @@ [%%expect{| Line _, characters 15-24: Error: Attribute `deprecatd' was not used. -Hint: Did you mean deprecated? + Hint: Did you mean deprecated? |}] let attr : _ Attribute.t = @@ -31,9 +31,10 @@ [%%expect{| Line _, characters 15-19: Error: Attribute `blah' was not used. -Hint: `blah' is available for type declarations but is used here in the -context of a core type. -Did you put it at the wrong level? + Hint: `blah' is available for type declarations but is used here in + the + context of a core type. + Did you put it at the wrong level? |}] let attr : _ Attribute.t = @@ -49,9 +50,10 @@ [%%expect{| Line _, characters 15-19: Error: Attribute `blah' was not used. -Hint: `blah' is available for expressions and type declarations but is used -here in the context of a core type. -Did you put it at the wrong level? + Hint: `blah' is available for expressions and type declarations but is + used + here in the context of a core type. + Did you put it at the wrong level? |}] (* Attribute drops *) diff -Nru ppxlib-0.24.0/test/driver/error_embedding/raiser.ml ppxlib-0.27.0/test/driver/error_embedding/raiser.ml --- ppxlib-0.24.0/test/driver/error_embedding/raiser.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/error_embedding/raiser.ml 2022-06-14 18:16:33.000000000 +0000 @@ -10,5 +10,4 @@ |> Context_free.Rule.extension let () = Driver.register_transformation ~rules:[ rule ] "test" - let () = Driver.standalone () diff -Nru ppxlib-0.24.0/test/driver/error_embedding/test.t/run.t ppxlib-0.27.0/test/driver/error_embedding/test.t/run.t --- ppxlib-0.24.0/test/driver/error_embedding/test.t/run.t 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/error_embedding/test.t/run.t 2022-06-14 18:16:33.000000000 +0000 @@ -4,11 +4,12 @@ $ export OCAML_ERROR_STYLE=short With the `-embed-errors` options, if a PPX raises, the first such exception -is caught and packed into an output AST +is caught and prepended to the last valid AST $ echo "let _ = [%raise]" > impl.ml $ ../raiser.exe -embed-errors impl.ml [%%ocaml.error "Raising inside the rewriter"] + let _ = [%raise ] The same is true when using the `-as-ppx` mode (note that the error is reported by ocaml itself) diff -Nru ppxlib-0.24.0/test/driver/exception_handling/deriver.ml ppxlib-0.27.0/test/driver/exception_handling/deriver.ml --- ppxlib-0.24.0/test/driver/exception_handling/deriver.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/exception_handling/deriver.ml 2022-06-14 18:16:33.000000000 +0000 @@ -3,8 +3,7 @@ let generate_impl_extension_node ~ctxt (_rec_flag, _type_declarations) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in let extension_node = - Location.Error.( - make ~loc "An error message in an extension node" ~sub:[] |> to_extension) + Location.error_extensionf ~loc "An error message in an extension node" in [ Ast_builder.Default.pstr_extension ~loc extension_node [] ] diff -Nru ppxlib-0.24.0/test/driver/exception_handling/extender.ml ppxlib-0.27.0/test/driver/exception_handling/extender.ml --- ppxlib-0.24.0/test/driver/exception_handling/extender.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/exception_handling/extender.ml 2022-06-14 18:16:33.000000000 +0000 @@ -3,8 +3,7 @@ let expand_into_extension_node ~ctxt = let loc = Expansion_context.Extension.extension_point_loc ctxt in let extension_node = - Location.Error.( - make ~loc "An error message in an extension node" ~sub:[] |> to_extension) + Location.error_extensionf ~loc "An error message in an extension node" in Ast_builder.Default.pexp_extension ~loc extension_node @@ -30,9 +29,7 @@ expand_raise_located_error let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension - let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension - let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension let () = diff -Nru ppxlib-0.24.0/test/driver/exception_handling/run.t ppxlib-0.27.0/test/driver/exception_handling/run.t --- ppxlib-0.24.0/test/driver/exception_handling/run.t 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/exception_handling/run.t 2022-06-14 18:16:33.000000000 +0000 @@ -68,9 +68,7 @@ [1] When the argument `-embed-errors` is added, the exception is caught -and the whole AST is replaced with a single error extension node. The -first line `let x = 1+1.` is thus not present in the AST, and no error -can be reported about it. +and the whole AST is prepended with an error extension node. In the case of extenders: @@ -78,6 +76,8 @@ $ echo "let _ = [%gen_raise_located_error]" >> impl.ml $ ./extender.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] + let x = 1 + 1. + let _ = [%gen_raise_located_error ] In the case of derivers @@ -86,12 +86,15 @@ $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml $ ./deriver.exe -embed-errors impl.ml [%%ocaml.error "A raised located error"] + type a = int + type b = int[@@deriving deriver_located_error] In the case of whole file transformations: $ echo "let x = 1+1. " > impl.ml $ ./whole_file_located_error.exe -embed-errors impl.ml [%%ocaml.error "A located error in a whole file transform"] + let x = 1 + 1. 3. Raising an exception. The exception is not caught by the driver. diff -Nru ppxlib-0.24.0/test/driver/exception_handling/whole_file_extension_point.ml ppxlib-0.27.0/test/driver/exception_handling/whole_file_extension_point.ml --- ppxlib-0.24.0/test/driver/exception_handling/whole_file_extension_point.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/exception_handling/whole_file_extension_point.ml 2022-06-14 18:16:33.000000000 +0000 @@ -10,9 +10,7 @@ | hd :: _ -> hd.pstr_loc in let extension_node = - Location.Error.( - make ~loc "An error message in an extension node" ~sub:[] - |> to_extension) + Location.error_extensionf ~loc "An error message in an extension node" in [ Ast_builder.Default.pstr_extension ~loc extension_node [] ]) "raise_exc") diff -Nru ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_greetings.ml ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/print_greetings.ml --- ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_greetings.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/print_greetings.ml 2022-06-14 18:16:33.000000000 +0000 @@ -16,7 +16,5 @@ (* the two rules need to be registered separately in order to test the `-apply` flag in run.t *) let () = Driver.register_transformation ~rules:[ hi_rule ] "print_hi" - let () = Driver.register_transformation ~rules:[ bye_rule ] "print_bye" - let () = Ppxlib.Driver.run_as_ppx_rewriter () diff -Nru ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml --- ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/print_magic_number.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1,9 +1,5 @@ let magic_length = String.length Astlib.Config.ast_impl_magic_number - let buf = Bytes.create magic_length - let len = input stdin buf 0 magic_length - let s = Bytes.sub_string buf 0 len - let () = Printf.printf "Magic number: %s" s diff -Nru ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/test.t/run.t ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/test.t/run.t --- ppxlib-0.24.0/test/driver/run_as_ppx_rewriter/test.t/run.t 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/driver/run_as_ppx_rewriter/test.t/run.t 2022-06-14 18:16:33.000000000 +0000 @@ -60,7 +60,7 @@ -locations-check Enable locations check only -apply Apply these transformations in order (comma-separated list) -dont-apply Exclude these transformations - -no-merge Do not merge context free transformations (better for debugging rewriters) + -no-merge Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf. -cookie NAME=EXPR Set the cookie NAME to EXPR --cookie Same as -cookie -help Display this list of options @@ -81,7 +81,7 @@ -locations-check Enable locations check only -apply Apply these transformations in order (comma-separated list) -dont-apply Exclude these transformations - -no-merge Do not merge context free transformations (better for debugging rewriters) + -no-merge Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf. -cookie NAME=EXPR Set the cookie NAME to EXPR --cookie Same as -cookie -help Display this list of options diff -Nru ppxlib-0.24.0/test/error_embedding/deriver.ml ppxlib-0.27.0/test/error_embedding/deriver.ml --- ppxlib-0.24.0/test/error_embedding/deriver.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/error_embedding/deriver.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,31 @@ +open Ppxlib + +let derive_a_string ~ctxt (_rec_flag, _type_declarations) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + let open Ast_builder.Default in + [ + pstr_value ~loc Nonrecursive + [ + { + pvb_pat = ppat_any ~loc; + pvb_expr = estring ~loc "derived_string"; + pvb_attributes = []; + pvb_loc = loc; + }; + ]; + ] + +let impl_generator_derive_a_string = + Deriving.Generator.V2.make_noarg derive_a_string + +let deriver_for_a_string = + Deriving.add "a_string" ~str_type_decl:impl_generator_derive_a_string + +let impl_generator_dependent = + Deriving.Generator.V2.make_noarg ~deps:[ deriver_for_a_string ] + derive_a_string + +let dependent_deriver = + Deriving.add "a_dependent_string" ~str_type_decl:impl_generator_dependent + +let () = Driver.standalone () diff -Nru ppxlib-0.24.0/test/error_embedding/dune ppxlib-0.27.0/test/error_embedding/dune --- ppxlib-0.24.0/test/error_embedding/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/error_embedding/dune 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,6 @@ +(executables + (names extender deriver) + (libraries ppxlib)) + +(cram + (deps extender.exe deriver.exe)) diff -Nru ppxlib-0.24.0/test/error_embedding/extender.ml ppxlib-0.27.0/test/error_embedding/extender.ml --- ppxlib-0.24.0/test/error_embedding/extender.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/error_embedding/extender.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,15 @@ +open Ppxlib + +let export_string ~ctxt e = + let loc = Expansion_context.Extension.extension_point_loc ctxt in + let open Ast_builder.Default in + estring ~loc e + +let export_string_extension = + Extension.V3.declare "export_string" Extension.Context.expression + Ast_pattern.(single_expr_payload (estring __)) + export_string + +let rule = Ppxlib.Context_free.Rule.extension export_string_extension +let () = Driver.register_transformation ~rules:[ rule ] "export_string" +let () = Driver.standalone () diff -Nru ppxlib-0.24.0/test/error_embedding/run.t ppxlib-0.27.0/test/error_embedding/run.t --- ppxlib-0.24.0/test/error_embedding/run.t 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/error_embedding/run.t 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,75 @@ +Most errors happening during ppxlib rewriting process are ultimately turned into +error extension nodes. + +Undefined derivers are turned into error nodes + + $ echo "type t = int [@@deriving undefined]" >> undefined_deriver.ml + $ ./deriver.exe undefined_deriver.ml + type t = int[@@deriving undefined] + include + struct + let _ = fun (_ : t) -> () + [%%ocaml.error + "Ppxlib.Deriving: 'undefined' is not a supported type deriving generator"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Error nodes are generated when parsing of payload fails. + +export_string expects only one argument, a string, and output it. +Anything else will embed an error extension node + + $ echo "let _ = [%export_string \"string\"]" > parsing_payload_extension.ml + $ echo "let _ = [%export_string \"string\" \"other\"]" >> parsing_payload_extension.ml + $ echo "let _ = [%export_string identifier]" >> parsing_payload_extension.ml + $ ./extender.exe parsing_payload_extension.ml + let _ = "string" + let _ = [%ocaml.error "constant expected"] + let _ = [%ocaml.error "constant expected"] + + $ echo "type a = int [@@deriving a_string]" > parsing_payload_deriver.ml + $ echo "type b = int [@@deriving a_string unexpected_args]" >> parsing_payload_deriver.ml + $ ./deriver.exe parsing_payload_deriver.ml + type a = int[@@deriving a_string] + include struct let _ = fun (_ : a) -> () + let _ = "derived_string" end[@@ocaml.doc "@inline"][@@merlin.hide + ] + type b = int[@@deriving a_string unexpected_args] + include + struct + let _ = fun (_ : b) -> () + [%%ocaml.error + "Ppxlib.Deriving: non-optional labelled argument or record expected"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Error nodes are generated when dependent derivers are not applied. + + $ echo "type a = int [@@deriving a_dependent_string]" > dependent_derivers.ml + $ ./deriver.exe dependent_derivers.ml + type a = int[@@deriving a_dependent_string] + include + struct + let _ = fun (_ : a) -> () + [%%ocaml.error + "Deriver a_string is needed for a_dependent_string, you need to add it before in the list"] + let _ = "derived_string" + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "type b = int [@@deriving a_dependent_string, a_string]" > dependent_derivers.ml + $ ./deriver.exe dependent_derivers.ml + type b = int[@@deriving (a_dependent_string, a_string)] + include + struct + let _ = fun (_ : b) -> () + [%%ocaml.error + "Deriver a_string is needed for a_dependent_string, you need to add it before in the list"] + let _ = "derived_string" + let _ = "derived_string" + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "type b = int [@@deriving a_string, a_dependent_string]" > dependent_derivers.ml + $ ./deriver.exe dependent_derivers.ml + type b = int[@@deriving (a_string, a_dependent_string)] + include + struct + let _ = fun (_ : b) -> () + let _ = "derived_string" + let _ = "derived_string" + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff -Nru ppxlib-0.24.0/test/expand-header-and-footer/dune ppxlib-0.27.0/test/expand-header-and-footer/dune --- ppxlib-0.24.0/test/expand-header-and-footer/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/expand-header-and-footer/dune 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.09.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.24.0/test/expand-header-and-footer/test.ml ppxlib-0.27.0/test/expand-header-and-footer/test.ml --- ppxlib-0.24.0/test/expand-header-and-footer/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/expand-header-and-footer/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,27 @@ +open Stdppx +open Ppxlib + +let _ = + let loc = Location.none in + let extension = + Extension.V3.declare_inline + "include" + Structure_item + Ast_pattern.(pstr __) + (fun ~ctxt:_ x -> x) + in + let rules = [ Context_free.Rule.extension extension ] in + let enclose_impl _ _ = [%str [%%include let a = 1]], [%str [%%include let c = 3]] in + Driver.V2.register_transformation ~rules ~enclose_impl "example" + +[%%expect{| +- : unit = () +|}] + +let b = 2 + +[%%expect{| +val a : int = 1 +val b : int = 2 +val c : int = 3 +|}] diff -Nru ppxlib-0.24.0/test/expect/dune ppxlib-0.27.0/test/expect/dune --- ppxlib-0.24.0/test/expect/dune 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/expect/dune 2022-06-14 18:16:33.000000000 +0000 @@ -10,6 +10,7 @@ ppxlib ppxlib.metaquot ppxlib.traverse + ppxlib.astlib findlib.top ppxlib_ast ;; We don't actually use findlib.dynload, however it is a diff -Nru ppxlib-0.24.0/test/expect/expect_test.ml ppxlib-0.27.0/test/expect/expect_test.ml --- ppxlib-0.24.0/test/expect/expect_test.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/expect/expect_test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -51,6 +51,26 @@ Ptop_def (Ppxlib.Selected_ast.to_ocaml Structure s') let main () = + let rec map_tree = function + | Outcometree.Oval_constr (name, params) -> + Outcometree.Oval_constr (name, List.map ~f:map_tree params) + | Oval_variant (name, Some param) -> + Oval_variant (name, Some (map_tree param)) + | Oval_string (s, maxlen, kind) -> + Oval_string (s, (if maxlen < 8 then 8 else maxlen), kind) + | Oval_tuple tl -> Oval_tuple (List.map ~f:map_tree tl) + | Oval_array tl -> Oval_array (List.map ~f:map_tree tl) + | Oval_list tl -> Oval_list (List.map ~f:map_tree tl) + | Oval_record fel -> + Oval_record + (List.map ~f:(fun (name, tree) -> (name, map_tree tree)) fel) + | tree -> tree + in + let print_out_value = !Toploop.print_out_value in + (* Achieve 4.14 printing behaviour, as introduced in + https://github.com/ocaml/ocaml/pull/10565 *) + (Toploop.print_out_value := + fun ppf tree -> print_out_value ppf (map_tree tree)); run_expect_test Sys.argv.(1) ~f:(fun file_contents lexbuf -> let chunks = Expect_lexer.split_file ~file_contents lexbuf in @@ -87,7 +107,8 @@ try let phr = apply_rewriters phr in if !Clflags.dump_source then - Format.fprintf ppf "%a@?" Pprintast.top_phrase phr; + Format.fprintf ppf "%a@?" Ppxlib.Pprintast.top_phrase + (Ppxlib.Selected_ast.Of_ocaml.copy_toplevel_phrase phr); ignore (Toploop.execute_phrase true ppf phr : bool) with exn -> Location.report_exception ppf exn)); Format.fprintf ppf "@?|}]@."); diff -Nru ppxlib-0.24.0/test/metaquot/dune ppxlib-0.27.0/test/metaquot/dune --- ppxlib-0.24.0/test/metaquot/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/metaquot/dune 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.14.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.24.0/test/metaquot/test.ml ppxlib-0.27.0/test/metaquot/test.ml --- ppxlib-0.24.0/test/metaquot/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/metaquot/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,330 @@ +let loc = Ppxlib.Location.none +[%%expect{| +val loc : Warnings.loc = + {Ppxlib.Location.loc_start = + {Lexing.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; + loc_end = + {Lexing.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; + loc_ghost = true} +|}] + +(* unannotated quotations *) + +let _ = [%expr ()] +[%%expect{| +- : Ppxlib.expression = +{Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []} +|}] + +let _ = [%pat? ()] +[%%expect{| +- : Ppxlib.pattern = +{Ppxlib_ast.Ast.ppat_desc = + Ppxlib_ast.Ast.Ppat_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + None); + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []} +|}] + +let _ = [%type: unit] +[%%expect{| +- : Ppxlib.core_type = +{Ppxlib_ast.Ast.ptyp_desc = + Ppxlib_ast.Ast.Ptyp_constr + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "unit"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}, + []); + ptyp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ptyp_loc_stack = []; ptyp_attributes = []} +|}] + +let _ = [%stri let _ = ()] +[%%expect{| +- : Ppxlib.structure_item = +{Ppxlib_ast.Ast.pstr_desc = + Ppxlib_ast.Ast.Pstr_value (Ppxlib_ast.Ast.Nonrecursive, + [{Ppxlib_ast.Ast.pvb_pat = + {Ppxlib_ast.Ast.ppat_desc = Ppxlib_ast.Ast.Ppat_any; + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []}; + pvb_expr = + {Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}; + pvb_attributes = []; + pvb_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}]); + pstr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}} +|}] + +let _ = [%sigi: include S] +[%%expect{| +- : Ppxlib.signature_item = +{Ppxlib_ast.Ast.psig_desc = + Ppxlib_ast.Ast.Psig_include + {Ppxlib_ast.Ast.pincl_mod = + {Ppxlib_ast.Ast.pmty_desc = + Ppxlib_ast.Ast.Pmty_ident + {Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "S"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + pmty_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pmty_attributes = []}; + pincl_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pincl_attributes = []}; + psig_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}} +|}] + +let _ = [%str let _ = ()] +[%%expect{| +- : Ppxlib_ast.Ast.structure = +[{Ppxlib_ast.Ast.pstr_desc = + Ppxlib_ast.Ast.Pstr_value (Ppxlib_ast.Ast.Nonrecursive, + [{Ppxlib_ast.Ast.pvb_pat = + {Ppxlib_ast.Ast.ppat_desc = Ppxlib_ast.Ast.Ppat_any; + ppat_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + ppat_loc_stack = []; ppat_attributes = []}; + pvb_expr = + {Ppxlib_ast.Ast.pexp_desc = + Ppxlib_ast.Ast.Pexp_construct + ({Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "()"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}; + pvb_attributes = []; + pvb_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}]); + pstr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = [%sig: include S] +[%%expect{| +- : Ppxlib_ast.Ast.signature = +[{Ppxlib_ast.Ast.psig_desc = + Ppxlib_ast.Ast.Psig_include + {Ppxlib_ast.Ast.pincl_mod = + {Ppxlib_ast.Ast.pmty_desc = + Ppxlib_ast.Ast.Pmty_ident + {Ppxlib_ast.Ast.txt = Ppxlib_ast.Ast.Lident "S"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + pmty_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pmty_attributes = []}; + pincl_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pincl_attributes = []}; + psig_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +(* mistyped escapes (not producing ASTs at all) *) + +let _ = [%expr [%e ()]] +[%%expect{| +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.expression +|}] + +let _ = [%pat? [%p ()]] +[%%expect{| +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.pattern +|}] + +let _ = [%type: [%t ()]] +[%%expect{| +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.core_type +|}] + +let _ = [%stri [%%i ()]] +[%%expect{| +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.structure_item +|}] + +let _ = [%sigi: [%%i ()]] +[%%expect{| +Line _, characters 21-23: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.signature_item +|}] diff -Nru ppxlib-0.24.0/test/patterns_as_and_drop/dune ppxlib-0.27.0/test/patterns_as_and_drop/dune --- ppxlib-0.24.0/test/patterns_as_and_drop/dune 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/patterns_as_and_drop/dune 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,13 @@ +(rule + (alias runtest) + (enabled_if + (>= %{ocaml_version} "4.10.0")) + (deps + (:test test.ml) + (package ppxlib)) + (action + (chdir + %{project_root} + (progn + (run expect-test %{test}) + (diff? %{test} %{test}.corrected))))) diff -Nru ppxlib-0.24.0/test/patterns_as_and_drop/test.ml ppxlib-0.27.0/test/patterns_as_and_drop/test.ml --- ppxlib-0.24.0/test/patterns_as_and_drop/test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ppxlib-0.27.0/test/patterns_as_and_drop/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -0,0 +1,127 @@ +[@@@ocamlformat "disable"] + +open Ppxlib + +(* Simple demo without [as__] and [drop] *) +let ___1 = + let loc = Location.none in + let ast = [%expr List.length xs = 0] in + let pat = + let open Ast_pattern in + let length () = + pexp_apply + (pexp_ident (ldot (lident (string "List")) (string "length"))) + ((nolabel ** __) ^:: nil) + in + let zero () = pexp_constant (pconst_integer (string "0") none) in + + pexp_apply + (pexp_ident (lident (string "="))) + ((nolabel ** length ()) ^:: (nolabel ** zero ()) ^:: nil) + in + + Ast_pattern.parse pat loc ast + ~on_error:(fun () -> "Error") + (fun _length_argument -> "Success. As expected") + +[%%expect{| +val ___1 : string = "Success. As expected" +|}] + +(* We could use [as__] to capture whole [List.length ...] expression, + and use [drop] to ignore length's argument *) +let ___2 = + let loc = Location.none in + let ast = [%expr List.length xs = 0] in + + let pat = + let open Ast_pattern in + let length () = + as__ + (pexp_apply + (pexp_ident (ldot (lident (string "List")) (string "length"))) + ((nolabel ** drop) ^:: nil)) + in + let zero () = as__ (pexp_constant (pconst_integer (string "0") none)) in + + pexp_apply + (pexp_ident (lident (string "="))) + ((nolabel ** length ()) ^:: (nolabel ** zero ()) ^:: nil) + in + + Ast_pattern.parse pat loc ast + ~on_error:(fun () -> "error") + (fun l r -> + Format.asprintf "Success with '%a' and '%a'. As expected" Pprintast.expression l Pprintast.expression r + ) + +[%%expect{| +val ___2 : string = "Success with 'List.length xs' and '0'. As expected" +|}] + +(* Pitfall. If we forget unit argument and will use [as__], the success case + will be fired before the error case. *) +let ___3 = + let loc = Location.none in + let ast = [%expr 1] in + + let pat () = + let open Ast_pattern in + as__ (pexp_constant (pconst_integer (string "0") none)) + in + let rez = Buffer.create 100 in + Ast_pattern.parse (pat ()) loc ast + ~on_error:(fun () -> Printf.bprintf rez "An error") + (fun zero_expr -> Buffer.add_string rez + (Format.asprintf "Successfully got '%a' but error right after that (NOT EXPECTED). " Pprintast.expression zero_expr)); + Buffer.contents rez + +[%%expect{| +val ___3 : string = + "Successfully got '1' but error right after that (NOT EXPECTED). An error" +|}] + +(* To avoid the pitfall above we could add extra () to delay evaluation *) +let ___4 = + let loc = Location.none in + let ast = [%expr 1] in + + let pat () = + let open Ast_pattern in + as__ (pexp_constant (pconst_integer (string "0") none)) + in + Ast_pattern.parse (pat ()) loc ast + ~on_error:(fun () () -> "Error, as expected") + (fun _zero_expr () -> "Success and error after that\n%!") + () + +[%%expect{| +val ___4 : string = "Error, as expected" +|}] + +(* But this pitfall is not introduced by [as__], it existed before too. *) +let ___5 = + let loc = Location.none in + let ast = [%expr string_of_int 43] in + let pat = + let open Ast_pattern in + pexp_apply + (pexp_ident (lident __)) + ((nolabel ** eint (int 42)) ^:: + (nolabel ** (pexp_ident (lident __))) ^:: + nil) + in + + let b = Buffer.create 10 in + let () = Ast_pattern.parse pat loc ast + ~on_error:(fun () -> Buffer.add_string b "It's an error") + (fun s -> + Printf.bprintf b "Partial success with '%s', but actually not, because... " s; + (fun _ -> Printf.bprintf b "no, it's total success")) + in + Buffer.contents b + +[%%expect{| +val ___5 : string = + "Partial success with 'string_of_int', but actually not, because... It's an error" +|}] diff -Nru ppxlib-0.24.0/test/quoter/test.ml ppxlib-0.27.0/test/quoter/test.ml --- ppxlib-0.24.0/test/quoter/test.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/test/quoter/test.ml 2022-06-14 18:16:33.000000000 +0000 @@ -71,8 +71,73 @@ pexp_loc_stack = []; pexp_attributes = []} |}] +let expr3 = + Ast.eapply ~loc:Location.none (Ast.evar "foo" ~loc:Location.none) [Ast.eunit ~loc:Location.none] + |> Quoter.quote quoter +[%%expect{| +val expr3 : expression = + {Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_apply + ({Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_ident + {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "__2"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}; + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}, + [(Ppxlib__.Import.Nolabel, + {Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_construct + ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []})]); + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []} +|}] + +Pprintast.string_of_expression expr3;; +[%%expect{| +- : string = "__2 ()" +|}] + let quoted = - let expr = Ast.elist ~loc:Location.none [expr1; expr2] in + let expr = Ast.elist ~loc:Location.none [expr1; expr2; expr3] in Quoter.sanitize quoter expr [%%expect{| val quoted : expression = @@ -81,7 +146,7 @@ [{Ppxlib__.Import.pvb_pat = {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_var - {Ppxlib__.Import.txt = "__1"; + {Ppxlib__.Import.txt = "__2"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; @@ -124,16 +189,49 @@ loc_ghost = true}; ppat_loc_stack = []; ppat_attributes = []}, {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_ident - {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "bar"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}; + Ppxlib__.Import.Pexp_apply + ({Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_ident + {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "foo"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}; + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []}, + [(Ppxlib__.Import.Nolabel, + {Ppxlib__.Import.pexp_desc = + Ppxlib__.Import.Pexp_construct + ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}, + None); + pexp_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}; + pexp_loc_stack = []; pexp_attributes = []})]); pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; @@ -164,7 +262,7 @@ {Ppxlib__.Import.pvb_pat = {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_var - {Ppxlib__.Import.txt = "__0"; + {Ppxlib__.Import.txt = "__1"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; @@ -184,48 +282,16 @@ ppat_loc_stack = []; ppat_attributes = []}; pvb_expr = {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_fun (Ppxlib__.Import.Nolabel, None, - {Ppxlib__.Import.ppat_desc = - Ppxlib__.Import.Ppat_construct - ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}, - None); - ppat_loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}; - ppat_loc_stack = []; ppat_attributes = []}, - {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_ident - {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "foo"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}; - pexp_loc = + Ppxlib__.Import.Pexp_ident + {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "bar"; + loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}; - pexp_loc_stack = []; pexp_attributes = []}); + loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; @@ -243,30 +309,33 @@ loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}], - {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_construct - ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "::"; - loc = - {Ppxlib__.Import.loc_start = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_end = - {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1}; - loc_ghost = true}}, - Some - {Ppxlib__.Import.pexp_desc = - Ppxlib__.Import.Pexp_tuple - [{Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident ...; - pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}; - ...]; - pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}); - pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}); - pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...} + loc_ghost = true}}; + {Ppxlib__.Import.pvb_pat = + {Ppxlib__.Import.ppat_desc = + Ppxlib__.Import.Ppat_var + {Ppxlib__.Import.txt = "__0"; + loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_end = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; + pos_bol = 0; pos_cnum = -1}; + loc_ghost = true}}; + ppat_loc = + {Ppxlib__.Import.loc_start = + {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = ...; loc_ghost = ...}; + ppat_loc_stack = ...; ppat_attributes = ...}; + pvb_expr = ...; pvb_attributes = ...; pvb_loc = ...}; + ...], + ...); + pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...} |}] Pprintast.string_of_expression quoted;; [%%expect{| -- : string = "let rec __1 () = bar\nand __0 () = foo in [__0; __1]" +- : string = +"let rec __2 () = foo ()\nand __1 = bar\nand __0 = foo in [__0; __1; __2 ()]" |}] diff -Nru ppxlib-0.24.0/traverse/ppxlib_traverse.ml ppxlib-0.27.0/traverse/ppxlib_traverse.ml --- ppxlib-0.24.0/traverse/ppxlib_traverse.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/traverse/ppxlib_traverse.ml 2022-06-14 18:16:33.000000000 +0000 @@ -11,15 +11,10 @@ List.mapi l ~f:(fun i x -> { txt = alphabet.(i); loc = get_loc x }) let evar_of_var { txt; loc } = evar ~loc txt - let pvar_of_var { txt; loc } = pvar ~loc txt - let tvar_of_var { txt; loc } = ptyp_var ~loc txt - let evars_of_vars = List.map ~f:evar_of_var - let pvars_of_vars = List.map ~f:pvar_of_var - let tvars_of_vars = List.map ~f:tvar_of_var module Backends = struct @@ -37,7 +32,6 @@ class type what = object method name : string - inherit reconstructors method class_params : @@ -50,7 +44,6 @@ (* Basic combinator type *) method typ : loc:Location.t -> core_type -> core_type - method any : loc:Location.t -> expression method combine : @@ -63,17 +56,11 @@ let mapper : what = object method name = "map" - inherit reconstructors - method class_params ~loc:_ = [] - method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr - method typ ~loc ty = ptyp_arrow ~loc Nolabel ty ty - method any ~loc = [%expr fun x -> x] method combine ~loc combinators ~reconstruct = @@ -86,17 +73,11 @@ let iterator : what = object method name = "iter" - inherit reconstructors - method class_params ~loc:_ = [] - method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr - method typ ~loc ty = [%type: [%t ty] -> unit] - method any ~loc = [%expr fun _ -> ()] method combine ~loc combinators ~reconstruct:_ = @@ -110,7 +91,6 @@ let folder : what = object method name = "fold" - inherit reconstructors method class_params ~loc = @@ -122,7 +102,6 @@ eabstract ~loc [ patt; pvar ~loc "acc" ] expr method typ ~loc ty = [%type: [%t ty] -> 'acc -> 'acc] - method any ~loc = [%expr fun _ acc -> acc] method combine ~loc combinators ~reconstruct:_ = @@ -139,7 +118,6 @@ let fold_mapper : what = object method name = "fold_map" - inherit reconstructors method class_params ~loc = @@ -151,7 +129,6 @@ eabstract ~loc [ patt; pvar ~loc "acc" ] expr method typ ~loc ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc] - method any ~loc = [%expr fun x acc -> (x, acc)] method combine ~loc combinators ~reconstruct = @@ -187,7 +164,6 @@ let uses_ctx = uses_var "ctx" in object method name = "map_with_context" - inherit reconstructors method class_params ~loc = @@ -200,7 +176,6 @@ else eabstract ~loc [ pvar ~loc "_ctx"; patt ] expr method typ ~loc ty = [%type: 'ctx -> [%t ty] -> [%t ty]] - method any ~loc = [%expr fun _ctx x -> x] method combine ~loc combinators ~reconstruct = @@ -220,11 +195,8 @@ [ (ptyp_var ~loc "res", (NoVariance, NoInjectivity)) ] method apply ~loc expr args = eapply ~loc expr args - method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr - method typ ~loc ty = [%type: [%t ty] -> 'res] - method any ~loc = [%expr self#other] method combine ~loc combinators ~reconstruct = @@ -479,11 +451,8 @@ class virtual blah = object method virtual record : (string * 'res) list -> 'res - method virtual constr : string -> 'res list -> 'res - method virtual tuple : 'res list -> 'res - method virtual other : 'a. 'a -> 'res end] with diff -Nru ppxlib-0.24.0/traverse_builtins/ppxlib_traverse_builtins.ml ppxlib-0.27.0/traverse_builtins/ppxlib_traverse_builtins.ml --- ppxlib-0.24.0/traverse_builtins/ppxlib_traverse_builtins.ml 2021-12-08 21:53:37.000000000 +0000 +++ ppxlib-0.27.0/traverse_builtins/ppxlib_traverse_builtins.ml 2022-06-14 18:16:33.000000000 +0000 @@ -1,14 +1,9 @@ module T = struct type 'a map = 'a -> 'a - type 'a iter = 'a -> unit - type ('a, 'acc) fold = 'a -> 'acc -> 'acc - type ('a, 'acc) fold_map = 'a -> 'acc -> 'a * 'acc - type ('ctx, 'a) map_with_context = 'ctx -> 'a -> 'a - type ('a, 'res) lift = 'a -> 'res end @@ -16,18 +11,14 @@ let any x = x in object method int : int T.map = any - method string : string T.map = any - method bool : bool T.map = any - method char : char T.map = any method option : 'a. 'a T.map -> 'a option T.map = fun f x -> match x with None -> None | Some x -> Some (f x) method list : 'a. 'a T.map -> 'a list T.map = List.map - method array : 'a. 'a T.map -> 'a array T.map = Array.map end @@ -35,18 +26,14 @@ let any = ignore in object method int : int T.iter = any - method string : string T.iter = any - method bool : bool T.iter = any - method char : char T.iter = any method option : 'a. 'a T.iter -> 'a option T.iter = fun f x -> match x with None -> () | Some x -> f x method list : 'a. 'a T.iter -> 'a list T.iter = List.iter - method array : 'a. 'a T.iter -> 'a array T.iter = Array.iter end @@ -54,11 +41,8 @@ let any _ acc = acc in object method int : (int, 'acc) T.fold = any - method string : (string, 'acc) T.fold = any - method bool : (bool, 'acc) T.fold = any - method char : (char, 'acc) T.fold = any method option : 'a. ('a, 'acc) T.fold -> ('a option, 'acc) T.fold = @@ -83,11 +67,8 @@ let any x acc = (x, acc) in object method int : (int, 'acc) T.fold_map = any - method string : (string, 'acc) T.fold_map = any - method bool : (bool, 'acc) T.fold_map = any - method char : (char, 'acc) T.fold_map = any method option : 'a. ('a, 'acc) T.fold_map -> ('a option, 'acc) T.fold_map = @@ -129,11 +110,8 @@ let any _ x = x in object method int : ('ctx, int) T.map_with_context = any - method string : ('ctx, string) T.map_with_context = any - method bool : ('ctx, bool) T.map_with_context = any - method char : ('ctx, char) T.map_with_context = any method option @@ -156,31 +134,18 @@ class virtual ['res] lift = object (self) method virtual other : 'a. ('a, 'res) T.lift - method virtual int : (int, 'res) T.lift - method virtual string : (string, 'res) T.lift - method virtual bool : (bool, 'res) T.lift - method virtual char : (char, 'res) T.lift - method virtual array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift - method virtual float : (float, 'res) T.lift - method virtual int32 : (int32, 'res) T.lift - method virtual int64 : (int64, 'res) T.lift - method virtual nativeint : (nativeint, 'res) T.lift - method virtual unit : (unit, 'res) T.lift - method virtual record : (string * 'res) list -> 'res - method virtual constr : string -> 'res list -> 'res - method virtual tuple : 'res list -> 'res method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift = @@ -199,34 +164,19 @@ class type ['res] std_lifters = object method other : 'a. ('a, 'res) T.lift - method int : (int, 'res) T.lift - method string : (string, 'res) T.lift - method bool : (bool, 'res) T.lift - method char : (char, 'res) T.lift - method array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift - method record : (string * 'res) list -> 'res - method constr : string -> 'res list -> 'res - method tuple : 'res list -> 'res - method float : (float, 'res) T.lift - method int32 : (int32, 'res) T.lift - method int64 : (int64, 'res) T.lift - method nativeint : (nativeint, 'res) T.lift - method unit : (unit, 'res) T.lift - method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift - method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift end