diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index bbc01112..08883bf1 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 diff --git a/astlib/ast_502.ml b/astlib/ast_502.ml index 4e0de317..9842c644 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 ]] @@ -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,66 @@ module Parsetree = struct pbop_loc : Location.t; } + 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] + 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 + (** [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_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = 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_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 + (** 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 e22dcdb8..811572d5 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 @@ -51,14 +63,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 +82,85 @@ 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_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, @@ -355,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 ccac5ded..cd707341 100644 --- a/astlib/migrate_502_501.ml +++ b/astlib/migrate_502_501.ml @@ -2,6 +2,17 @@ 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 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 @@ -68,14 +79,84 @@ 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 -> ( + 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 = + 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 = Option.map 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_desc = Pparam_val (lbl, exp0, p); + pparam_loc; + } -> + 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 = pparam_loc; + pexp_loc_stack = []; + pexp_attributes = []; + } + | { 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 = pparam_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 +406,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 +416,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 @@ -355,7 +436,7 @@ and copy_core_type_desc : 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, @@ -368,6 +449,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 = diff --git a/ppxlib.opam b/ppxlib.opam index be6144f8..91bfd947 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 00000000..616dda46 --- /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" ] +]