From a0803d9f356a35829c3907d7aa73d5350f89c474 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 14 Sep 2023 12:12:02 +0200 Subject: [PATCH] 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 f1dece96..fc74b1c2 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 abc8f9e0..1c131ebb 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);