From ff95254a13fc64127aa729a73ae9dd8ee6dac34c Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 1 Aug 2023 17:14:57 +0200 Subject: [PATCH 1/6] Preliminary support for 502 parsetree changes (it compiles, at least) Signed-off-by: Paul-Elliot --- astlib/ast_502.ml | 108 +++++++++++++++++++++++++++----------- astlib/migrate_501_502.ml | 33 ++++++++---- astlib/migrate_502_501.ml | 86 ++++++++++++++++++++++++++---- 3 files changed, 175 insertions(+), 52 deletions(-) diff --git a/astlib/ast_502.ml b/astlib/ast_502.ml index 4e0de3173..2a3ca5c2c 100644 --- a/astlib/ast_502.ml +++ b/astlib/ast_502.ml @@ -192,6 +192,7 @@ module Parsetree = struct {!value_description}. *) | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) | Ptyp_extension of extension (** [[%id]]. *) and package_type = Longident.t loc * (Longident.t loc * core_type) list @@ -322,41 +323,30 @@ module Parsetree = struct - [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 - (** [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_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) | Pexp_apply of expression * (arg_label * expression) list - (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] - represents [E0 ~l1:E1 ... ~ln:En] + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] - [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). + [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] - *) + Invariant: [n > 0] + *) | Pexp_match of expression * case list (** [match E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_try of expression * case list @@ -466,6 +456,60 @@ module Parsetree = struct pbop_loc : Location.t; } + and function_param (*IF_CURRENT = Parsetree.function_param *) = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc * Location.t + (** [Pparam_newtype (x, loc)] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas [loc] is + the location of the [(type x)] as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ Pparam_newtype (a, loc1); + Pparam_newtype (b, loc2); + Pparam_newtype (c, loc3); + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + + and function_body (*IF_CURRENT = Parsetree.function_body *) = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) + (** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + + and type_constraint (*IF_CURRENT = Parsetree.type_constraint *) = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type + (** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description (*IF_CURRENT = Parsetree.value_description *) = diff --git a/astlib/migrate_501_502.ml b/astlib/migrate_501_502.ml index e22dcdb84..7ad0868ac 100644 --- a/astlib/migrate_501_502.ml +++ b/astlib/migrate_501_502.ml @@ -51,14 +51,15 @@ and copy_expression : Ast_501.Parsetree.pexp_loc_stack; Ast_501.Parsetree.pexp_attributes; } -> + let pexp_loc = copy_location pexp_loc in { - Ast_502.Parsetree.pexp_desc = copy_expression_desc pexp_desc; - Ast_502.Parsetree.pexp_loc = copy_location pexp_loc; + Ast_502.Parsetree.pexp_desc = copy_expression_desc pexp_loc pexp_desc; + Ast_502.Parsetree.pexp_loc; Ast_502.Parsetree.pexp_loc_stack = copy_location_stack pexp_loc_stack; Ast_502.Parsetree.pexp_attributes = copy_attributes pexp_attributes; } -and copy_expression_desc : +and copy_expression_desc loc : Ast_501.Parsetree.expression_desc -> Ast_502.Parsetree.expression_desc = function | Ast_501.Parsetree.Pexp_ident x0 -> @@ -69,13 +70,25 @@ and copy_expression_desc : Ast_502.Parsetree.Pexp_let (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) | Ast_501.Parsetree.Pexp_function x0 -> - Ast_502.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_501.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_502.Parsetree.Pexp_fun - ( copy_arg_label x0, - Option.map copy_expression x1, - copy_pattern x2, - copy_expression x3 ) + Ast_502.Parsetree.Pexp_function + ( [], + None, + Ast_502.Parsetree.Pfunction_cases (List.map copy_case x0, loc, []) ) + | Ast_501.Parsetree.Pexp_fun (arg_label, opt_expr, pat, expr) -> + Ast_502.Parsetree.Pexp_function + ( [ + Pparam_val + ( copy_arg_label arg_label, + Option.map copy_expression opt_expr, + copy_pattern pat ); + ], + None, + Ast_502.Parsetree.Pfunction_body (copy_expression expr) ) + (* Ast_502.Parsetree.Pexp_fun *) + (* ( copy_arg_label x0, *) + (* Option.map copy_expression x1, *) + (* copy_pattern x2, *) + (* copy_expression x3 ) *) | Ast_501.Parsetree.Pexp_apply (x0, x1) -> Ast_502.Parsetree.Pexp_apply ( copy_expression x0, diff --git a/astlib/migrate_502_501.ml b/astlib/migrate_502_501.ml index ccac5dedd..d4f5ffb2d 100644 --- a/astlib/migrate_502_501.ml +++ b/astlib/migrate_502_501.ml @@ -2,6 +2,10 @@ open Stdlib0 module From = Ast_502 module To = Ast_501 +let migration_error loc missing_feature = + Location.raise_errorf ~loc + "migration error: %s is not supported before OCaml 5.02" missing_feature + let rec copy_toplevel_phrase : Ast_502.Parsetree.toplevel_phrase -> Ast_501.Parsetree.toplevel_phrase = function @@ -68,14 +72,74 @@ and copy_expression_desc : | Ast_502.Parsetree.Pexp_let (x0, x1, x2) -> Ast_501.Parsetree.Pexp_let (copy_rec_flag x0, List.map copy_value_binding x1, copy_expression x2) - | Ast_502.Parsetree.Pexp_function x0 -> - Ast_501.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_502.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_501.Parsetree.Pexp_fun - ( copy_arg_label x0, - Option.map copy_expression x1, - copy_pattern x2, - copy_expression x3 ) + | Ast_502.Parsetree.Pexp_function (params, tconstraint, body) -> + let expr = + match body with + | Pfunction_body expr -> copy_expression expr + | Pfunction_cases (cases, loc, attrs) -> + { + Ast_501.Parsetree.pexp_desc = + Ast_501.Parsetree.Pexp_function (List.map copy_case cases); + pexp_loc = copy_location loc; + pexp_loc_stack = []; + pexp_attributes = copy_attributes attrs; + } + in + let expr = + match tconstraint with + | None -> expr + | Some (Pconstraint c) -> + { + Ast_501.Parsetree.pexp_desc = + Ast_501.Parsetree.Pexp_constraint (expr, copy_core_type c); + pexp_loc = expr.pexp_loc; + pexp_loc_stack = []; + pexp_attributes = []; + } + | Some (Pcoerce (c1, c2)) -> + let c1 = + match c1 with None -> None | Some c1 -> Some (copy_core_type c1) + in + { + Ast_501.Parsetree.pexp_desc = + Ast_501.Parsetree.Pexp_coerce (expr, c1, copy_core_type c2); + pexp_loc = expr.pexp_loc; + pexp_loc_stack = []; + pexp_attributes = []; + } + in + let expr = + List.fold_right + (fun param expr -> + match param with + | Ast_502.Parsetree.Pparam_val (lbl, exp0, p) -> + let pexp_desc = + Ast_501.Parsetree.Pexp_fun + ( copy_arg_label lbl, + Option.map copy_expression exp0, + copy_pattern p, + expr ) + in + { + Ast_501.Parsetree.pexp_desc; + pexp_loc = expr.pexp_loc; + pexp_loc_stack = []; + pexp_attributes = []; + } + | Pparam_newtype (x, loc) -> + let pexp_desc = + Ast_501.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x, expr) + in + { + Ast_501.Parsetree.pexp_desc; + pexp_loc = loc; + pexp_loc_stack = []; + pexp_attributes = []; + }) + params expr + in + expr.pexp_desc + (* Ast_501.Parsetree.Pexp_function (List.map copy_case x0) *) | Ast_502.Parsetree.Pexp_apply (x0, x1) -> Ast_501.Parsetree.Pexp_apply ( copy_expression x0, @@ -325,7 +389,7 @@ and copy_core_type : Ast_502.Parsetree.core_type -> Ast_501.Parsetree.core_type Ast_502.Parsetree.ptyp_attributes; } -> { - Ast_501.Parsetree.ptyp_desc = copy_core_type_desc ptyp_desc; + Ast_501.Parsetree.ptyp_desc = copy_core_type_desc ptyp_loc ptyp_desc; Ast_501.Parsetree.ptyp_loc = copy_location ptyp_loc; Ast_501.Parsetree.ptyp_loc_stack = copy_location_stack ptyp_loc_stack; Ast_501.Parsetree.ptyp_attributes = copy_attributes ptyp_attributes; @@ -335,7 +399,7 @@ and copy_location_stack : Ast_502.Parsetree.location_stack -> Ast_501.Parsetree.location_stack = fun x -> List.map copy_location x -and copy_core_type_desc : +and copy_core_type_desc loc : Ast_502.Parsetree.core_type_desc -> Ast_501.Parsetree.core_type_desc = function | Ast_502.Parsetree.Ptyp_any -> Ast_501.Parsetree.Ptyp_any @@ -368,6 +432,8 @@ and copy_core_type_desc : Ast_501.Parsetree.Ptyp_package (copy_package_type x0) | Ast_502.Parsetree.Ptyp_extension x0 -> Ast_501.Parsetree.Ptyp_extension (copy_extension x0) + | Ast_502.Parsetree.Ptyp_open (x0, x1) -> + migration_error loc "module open in types" and copy_package_type : Ast_502.Parsetree.package_type -> Ast_501.Parsetree.package_type = From 4d6a43460c932c0630177b0aa7cf94a3f694a0c2 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 3 Aug 2023 20:13:15 +0200 Subject: [PATCH 2/6] Add locations for Pparam Signed-off-by: Paul-Elliot --- astlib/ast_502.ml | 22 ++++++++++++++-------- astlib/migrate_501_502.ml | 12 ++++++++---- astlib/migrate_502_501.ml | 11 +++++++---- 3 files changed, 29 insertions(+), 16 deletions(-) diff --git a/astlib/ast_502.ml b/astlib/ast_502.ml index 2a3ca5c2c..7766f208b 100644 --- a/astlib/ast_502.ml +++ b/astlib/ast_502.ml @@ -456,7 +456,7 @@ module Parsetree = struct pbop_loc : Location.t; } - and function_param (*IF_CURRENT = Parsetree.function_param *) = + and function_param_desc (*IF_CURRENT = Parsetree.function_param_desc *) = | Pparam_val of arg_label * expression option * pattern (** [Pparam_val (lbl, exp0, P)] represents the parameter: - [P] @@ -475,17 +475,18 @@ module Parsetree = struct Note: If [E0] is provided, only {{!Asttypes.arg_label.Optional}[Optional]} is allowed. *) - | Pparam_newtype of string loc * Location.t - (** [Pparam_newtype (x, loc)] represents the parameter [(type x)]. - [x] carries the location of the identifier, whereas [loc] is - the location of the [(type x)] as a whole. + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. Multiple parameters [(type a b c)] are represented as multiple [Pparam_newtype] nodes, let's say: - {[ [ Pparam_newtype (a, loc1); - Pparam_newtype (b, loc2); - Pparam_newtype (c, loc3); + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; ] ]} @@ -495,6 +496,11 @@ module Parsetree = struct variables [a], [b], and [c] in the source code. *) + and function_param (*IF_CURRENT = Parsetree.function_param *) = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + and function_body (*IF_CURRENT = Parsetree.function_body *) = | Pfunction_body of expression | Pfunction_cases of case list * Location.t * attributes diff --git a/astlib/migrate_501_502.ml b/astlib/migrate_501_502.ml index 7ad0868ac..f1dece962 100644 --- a/astlib/migrate_501_502.ml +++ b/astlib/migrate_501_502.ml @@ -77,10 +77,14 @@ and copy_expression_desc loc : | Ast_501.Parsetree.Pexp_fun (arg_label, opt_expr, pat, expr) -> Ast_502.Parsetree.Pexp_function ( [ - Pparam_val - ( copy_arg_label arg_label, - Option.map copy_expression opt_expr, - copy_pattern pat ); + { + pparam_desc = + Pparam_val + ( copy_arg_label arg_label, + Option.map copy_expression opt_expr, + copy_pattern pat ); + pparam_loc = loc; + }; ], None, Ast_502.Parsetree.Pfunction_body (copy_expression expr) ) diff --git a/astlib/migrate_502_501.ml b/astlib/migrate_502_501.ml index d4f5ffb2d..abc8f9e08 100644 --- a/astlib/migrate_502_501.ml +++ b/astlib/migrate_502_501.ml @@ -112,7 +112,10 @@ and copy_expression_desc : List.fold_right (fun param expr -> match param with - | Ast_502.Parsetree.Pparam_val (lbl, exp0, p) -> + | { + Ast_502.Parsetree.pparam_desc = Pparam_val (lbl, exp0, p); + pparam_loc; + } -> let pexp_desc = Ast_501.Parsetree.Pexp_fun ( copy_arg_label lbl, @@ -122,17 +125,17 @@ and copy_expression_desc : in { Ast_501.Parsetree.pexp_desc; - pexp_loc = expr.pexp_loc; + pexp_loc = pparam_loc; pexp_loc_stack = []; pexp_attributes = []; } - | Pparam_newtype (x, loc) -> + | { pparam_desc = Pparam_newtype x; pparam_loc } -> let pexp_desc = Ast_501.Parsetree.Pexp_newtype (copy_loc (fun x -> x) x, expr) in { Ast_501.Parsetree.pexp_desc; - pexp_loc = loc; + pexp_loc = pparam_loc; pexp_loc_stack = []; pexp_attributes = []; }) From a0803d9f356a35829c3907d7aa73d5350f89c474 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 14 Sep 2023 12:12:02 +0200 Subject: [PATCH 3/6] 51 -> 52 migration for Pexp_function Pexp_fun and Pexp_function become Pexp_function, which has a list of argument, a type annotation and a body that can possibly be a list of cases. We need to be careful not to rewrite any chain of Pexp_fun into the new node as that would change the semantics of the program after a roundtrip. A synthetic attribute is used to signal whether or not a chain of Pexp_fun or Pexp_function should be considered the same function or not. We do not need such an attribute for type annotations as that is unlikely to cause problem until the next AST bump. Co-authored-by: Paul-Elliot Co-authored-by: Jules Aguillon Signed-off-by: Paul-Elliot Signed-off-by: Jules Aguillon --- astlib/migrate_501_502.ml | 106 +++++++++++++++++++++++++++++++------- astlib/migrate_502_501.ml | 22 ++++++-- 2 files changed, 105 insertions(+), 23 deletions(-) diff --git a/astlib/migrate_501_502.ml b/astlib/migrate_501_502.ml index f1dece962..fc74b1c2d 100644 --- a/astlib/migrate_501_502.ml +++ b/astlib/migrate_501_502.ml @@ -2,6 +2,18 @@ open Stdlib0 module From = Ast_501 module To = Ast_502 +(** Look for a particular attribute and remove it from the list. Attributes are + used to make certain migrations round-trip. Returns [None] if the specified + attribute is not found. *) +let extract_attr name (attrs : Ast_501.Parsetree.attributes) = + let rec loop acc = function + | [] -> (false, List.rev acc) + | { Ast_501.Parsetree.attr_name = { txt; _ }; _ } :: q when txt = name -> + (true, List.rev_append acc q) + | hd :: tl -> loop (hd :: acc) tl + in + loop [] attrs + let rec copy_toplevel_phrase : Ast_501.Parsetree.toplevel_phrase -> Ast_502.Parsetree.toplevel_phrase = function @@ -74,25 +86,81 @@ and copy_expression_desc loc : ( [], None, Ast_502.Parsetree.Pfunction_cases (List.map copy_case x0, loc, []) ) - | Ast_501.Parsetree.Pexp_fun (arg_label, opt_expr, pat, expr) -> - Ast_502.Parsetree.Pexp_function - ( [ - { - pparam_desc = - Pparam_val - ( copy_arg_label arg_label, - Option.map copy_expression opt_expr, - copy_pattern pat ); - pparam_loc = loc; - }; - ], - None, - Ast_502.Parsetree.Pfunction_body (copy_expression expr) ) - (* Ast_502.Parsetree.Pexp_fun *) - (* ( copy_arg_label x0, *) - (* Option.map copy_expression x1, *) - (* copy_pattern x2, *) - (* copy_expression x3 ) *) + | Ast_501.Parsetree.Pexp_fun (arg_label, opt_default, pat, expr) -> + let take_body (e : Ast_501.Parsetree.expression) = + match e.pexp_desc with + | Ast_501.Parsetree.Pexp_function case_list -> + Ast_502.Parsetree.Pfunction_cases + ( List.map copy_case case_list, + e.pexp_loc, + copy_attributes e.pexp_attributes ) + | _ -> Ast_502.Parsetree.Pfunction_body (copy_expression e) + in + let rec take_arguments acc (e : Ast_501.Parsetree.expression) = + if e.pexp_attributes <> [] then + (* The attribute list is not empty, none of these nodes could have + been created by the downward migration. Except for [Pexp_fun], for + which we add a ghost attribute to help us roundtrip. *) + let _, attrs = + extract_attr "ppxlib.migration.stop_taking" e.pexp_attributes + in + ( acc, + None, + Ast_502.Parsetree.Pfunction_body + (copy_expression { e with pexp_attributes = attrs }) ) + else + (* These nodes are likely to have been synthetized during the + downward migration. *) + match e.pexp_desc with + | Ast_501.Parsetree.Pexp_fun (arg_label, opt_default, pat, expr) -> + take_arguments_fun acc arg_label opt_default pat expr + | Ast_501.Parsetree.Pexp_newtype (t, expr) -> + let acc = + { + Ast_502.Parsetree.pparam_loc = t.loc; + pparam_desc = Pparam_newtype t; + } + :: acc + in + take_arguments acc expr + | Ast_501.Parsetree.Pexp_constraint (exp, ct) -> + (* These two expression are represented the same on 5.1 but + differently on 5.2: + {[ + let _ = fun x : (_ -> int) -> fun y -> x+y + let _ = fun x -> ((fun y -> x+y) : _ -> int) + ]} + We normalize the second into the first when migrating to 5.2, + making the migration 5.2->5.1->5.2 not roundtrip but hopefully + without change in semantics. *) + let ct = + Some (Ast_502.Parsetree.Pconstraint (copy_core_type ct)) + in + (acc, ct, take_body exp) + | Ast_501.Parsetree.Pexp_coerce (exp, c1, c2) -> + (* Same as above, might not roundtrip but hopefully OK. *) + let c1 = Option.map copy_core_type c1 + and c2 = copy_core_type c2 in + (acc, Some (Ast_502.Parsetree.Pcoerce (c1, c2)), take_body e) + | _ -> (acc, None, take_body e) + and take_arguments_fun acc arg_label opt_default pat expr = + let acc = + let pparam_desc = + Ast_502.Parsetree.Pparam_val + ( copy_arg_label arg_label, + Option.map copy_expression opt_default, + copy_pattern pat ) + in + (* Best-effort location. *) + { Ast_502.Parsetree.pparam_loc = pat.ppat_loc; pparam_desc } :: acc + in + take_arguments acc expr + in + (* The argument list returned by [take_arguments] is reversed *) + let arg_list, type_constraint, body = + take_arguments_fun [] arg_label opt_default pat expr + in + Ast_502.Parsetree.Pexp_function (List.rev arg_list, type_constraint, body) | Ast_501.Parsetree.Pexp_apply (x0, x1) -> Ast_502.Parsetree.Pexp_apply ( copy_expression x0, diff --git a/astlib/migrate_502_501.ml b/astlib/migrate_502_501.ml index abc8f9e08..1c131ebbb 100644 --- a/astlib/migrate_502_501.ml +++ b/astlib/migrate_502_501.ml @@ -6,6 +6,13 @@ let migration_error loc missing_feature = Location.raise_errorf ~loc "migration error: %s is not supported before OCaml 5.02" missing_feature +let mk_ghost_attr name = + { + Ast_501.Parsetree.attr_name = { Location.txt = name; loc = Location.none }; + attr_payload = PStr []; + attr_loc = Location.none; + } + let rec copy_toplevel_phrase : Ast_502.Parsetree.toplevel_phrase -> Ast_501.Parsetree.toplevel_phrase = function @@ -75,7 +82,16 @@ and copy_expression_desc : | Ast_502.Parsetree.Pexp_function (params, tconstraint, body) -> let expr = match body with - | Pfunction_body expr -> copy_expression expr + | Pfunction_body expr -> ( + match expr.pexp_desc with + | Pexp_function _ -> + (* We don't want this [fun] to be merged with the parent during + the round-trip. This attribute signals that this expression + really is the body of the function. *) + let attr = mk_ghost_attr "ppxlib.migration.stop_taking" in + let expr = copy_expression expr in + { expr with pexp_attributes = attr :: expr.pexp_attributes } + | _ -> copy_expression expr) | Pfunction_cases (cases, loc, attrs) -> { Ast_501.Parsetree.pexp_desc = @@ -97,9 +113,7 @@ and copy_expression_desc : pexp_attributes = []; } | Some (Pcoerce (c1, c2)) -> - let c1 = - match c1 with None -> None | Some c1 -> Some (copy_core_type c1) - in + let c1 = Option.map copy_core_type c1 in { Ast_501.Parsetree.pexp_desc = Ast_501.Parsetree.Pexp_coerce (expr, c1, copy_core_type c2); From 5a051d887be05c5d0fe05c623f853c93e65a4ccb Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 4 Dec 2023 14:02:56 +0100 Subject: [PATCH 4/6] fix ptyp_alias Signed-off-by: Paul-Elliot --- astlib/ast_502.ml | 2 +- astlib/migrate_501_502.ml | 2 +- astlib/migrate_502_501.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/astlib/ast_502.ml b/astlib/ast_502.ml index 7766f208b..9842c6445 100644 --- a/astlib/ast_502.ml +++ b/astlib/ast_502.ml @@ -147,7 +147,7 @@ module Parsetree = struct - [T #tconstr] when [l=[T]], - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * label list option (** [Ptyp_variant([`A;`B], flag, labels)] represents: - [[ `A|`B ]] diff --git a/astlib/migrate_501_502.ml b/astlib/migrate_501_502.ml index fc74b1c2d..811572d5b 100644 --- a/astlib/migrate_501_502.ml +++ b/astlib/migrate_501_502.ml @@ -440,7 +440,7 @@ and copy_core_type_desc : Ast_502.Parsetree.Ptyp_class (copy_loc copy_Longident_t x0, List.map copy_core_type x1) | Ast_501.Parsetree.Ptyp_alias (x0, x1) -> - Ast_502.Parsetree.Ptyp_alias (copy_core_type x0, x1) + Ast_502.Parsetree.Ptyp_alias (copy_core_type x0, { Ast_502.Asttypes.txt = x1; loc = x0.ptyp_loc } ) | Ast_501.Parsetree.Ptyp_variant (x0, x1, x2) -> Ast_502.Parsetree.Ptyp_variant ( List.map copy_row_field x0, diff --git a/astlib/migrate_502_501.ml b/astlib/migrate_502_501.ml index 1c131ebbb..cd7073411 100644 --- a/astlib/migrate_502_501.ml +++ b/astlib/migrate_502_501.ml @@ -436,7 +436,7 @@ and copy_core_type_desc loc : Ast_501.Parsetree.Ptyp_class (copy_loc copy_Longident_t x0, List.map copy_core_type x1) | Ast_502.Parsetree.Ptyp_alias (x0, x1) -> - Ast_501.Parsetree.Ptyp_alias (copy_core_type x0, x1) + Ast_501.Parsetree.Ptyp_alias (copy_core_type x0, x1.txt) | Ast_502.Parsetree.Ptyp_variant (x0, x1, x2) -> Ast_501.Parsetree.Ptyp_variant ( List.map copy_row_field x0, From fe7292284a5e8dd6bcedf9abf6cf71c3e6f091da Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 7 Dec 2023 20:59:11 +0100 Subject: [PATCH 5/6] Add pin-depends for CI to run Signed-off-by: Paul-Elliot --- ppxlib.opam | 3 +++ ppxlib.opam.template | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 ppxlib.opam.template diff --git a/ppxlib.opam b/ppxlib.opam index be6144f8b..91bfd9471 100644 --- a/ppxlib.opam +++ b/ppxlib.opam @@ -51,3 +51,6 @@ build: [ ] ] dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" +pin-depends: [ + [ "ocaml-compiler-libs.v0.11.0" "git+https://github.com/art-w/ocaml-compiler-libs.git#ocaml-5.2-trunk" ] +] diff --git a/ppxlib.opam.template b/ppxlib.opam.template new file mode 100644 index 000000000..616dda46e --- /dev/null +++ b/ppxlib.opam.template @@ -0,0 +1,3 @@ +pin-depends: [ + [ "ocaml-compiler-libs.v0.11.0" "git+https://github.com/art-w/ocaml-compiler-libs.git#ocaml-5.2-trunk" ] +] From 43a59ee856eb5493e87a5e2a744d1924ab958bac Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 8 Dec 2023 08:45:09 +0100 Subject: [PATCH 6/6] run tests with trunk Signed-off-by: Paul-Elliot --- .github/workflows/build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index bbc011123..08883bf15 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -32,7 +32,7 @@ jobs: - name: Install ppxlib dependencies run: | - opam install ./ppxlib.opam --deps-only + opam install ./ppxlib.opam --deps-only --with-test - name: Show configuration run: | @@ -42,4 +42,4 @@ jobs: opam list - name: Build the ppxlib - run: opam exec -- dune build -p ppxlib + run: opam exec -- dune test -p ppxlib