From ad05df880d5ede80e9f4d7eae5a035f18d8fbeba Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 12 Dec 2023 12:16:11 -0500 Subject: [PATCH 1/2] Demonstrate bug in using ppxes with certain jane syntax elements --- ocaml/parsing/pprintast.ml | 12 +++++++-- ocaml/testsuite/tests/parsetree/ppx_no_op.ml | 8 ++++++ .../tests/parsetree/source_jane_street.ml | 26 +++++++++++++++---- .../parsetree/test_ppx.compilers.reference | 9 +++++++ ocaml/testsuite/tests/parsetree/test_ppx.ml | 19 ++++++++++++++ 5 files changed, 67 insertions(+), 7 deletions(-) create mode 100644 ocaml/testsuite/tests/parsetree/ppx_no_op.ml create mode 100644 ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference create mode 100644 ocaml/testsuite/tests/parsetree/test_ppx.ml diff --git a/ocaml/parsing/pprintast.ml b/ocaml/parsing/pprintast.ml index 85d21fe1352..33c4501e56e 100644 --- a/ocaml/parsing/pprintast.ml +++ b/ocaml/parsing/pprintast.ml @@ -1742,10 +1742,18 @@ and type_def_list ctxt f (rf, exported, l) = else if exported then " =" else " :=" in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + let layout_annot, x = + match Jane_syntax.Layouts.of_type_declaration x with + | None -> "", x + | Some (jkind, remaining_attributes) -> + Printf.sprintf " : %s" + (Jane_asttypes.jkind_to_string jkind.txt), + { x with ptype_attributes = remaining_attributes } + in + pp f "@[<2>%s %a%a%s%s%s%a@]%a" kwd nonrec_flag rf (type_params ctxt) x.ptype_params - x.ptype_name.txt eq + x.ptype_name.txt layout_annot eq (type_declaration ctxt) x (item_attributes ctxt) x.ptype_attributes in diff --git a/ocaml/testsuite/tests/parsetree/ppx_no_op.ml b/ocaml/testsuite/tests/parsetree/ppx_no_op.ml new file mode 100644 index 00000000000..b23826e2088 --- /dev/null +++ b/ocaml/testsuite/tests/parsetree/ppx_no_op.ml @@ -0,0 +1,8 @@ +open Ast_mapper + +(* This PPX rewriter does nothing. *) + +let () = + Language_extension.enable_maximal (); + Ast_mapper.register "no-op" (fun _ -> Ast_mapper.default_mapper); +;; diff --git a/ocaml/testsuite/tests/parsetree/source_jane_street.ml b/ocaml/testsuite/tests/parsetree/source_jane_street.ml index c76e523a97b..ed347f18694 100644 --- a/ocaml/testsuite/tests/parsetree/source_jane_street.ml +++ b/ocaml/testsuite/tests/parsetree/source_jane_street.ml @@ -23,6 +23,12 @@ let f (type a : immediate) (type b : immediate) (type (c : immediate) (d : immediate)) = ();; +module type S_for_layouts = sig + type t : float64 +end;; + +type ('a : immediate) for_layouts = 'a;; + (******************) (* Comprehensions *) @@ -61,7 +67,7 @@ let f (type a : immediate) (type b : immediate) (* Local *) (* parameters *) -let f (local_ x) ~(local_ y) ~z:(local_ z) ?foo:(local_ w = 1) = x + y + z + w;; +let f (local_ x) ~(local_ y) ~z:(local_ z) ?foo:(local_ w = 1) () = x + y + z + w;; (* bindings *) let g () = @@ -94,17 +100,22 @@ type 'a parameterized_record = { type fn = local_ int -> local_ int;; type nested_fn = (local_ int -> local_ int) -> local_ int;; type ('a, 'b) labeled_fn = - a:local_ 'a -> ?b:local_ b -> local_ 'a -> (int -> local_ 'b);; + a:local_ 'a -> ?b:local_ 'b -> local_ 'a -> (int -> local_ 'b);; (*******************) (* Include functor *) +module F_struct (_ : sig end) = struct +end + +module type F_sig = functor (_ : sig end) -> sig end + module T = struct - include functor F + include functor F_struct end;; module type S = sig - include functor F + include functor F_sig end;; (********************) @@ -115,10 +126,15 @@ let f x = | [::] -> [::] | ([:x:] [@test.attr1]) -> (([:x:])[@test.attr1]) | ([:x;y:] [@test.attr2][@test.attr3]) -> - ([:x;y:] [@test.attr2][@test.attr3]);; + ([:x;y:] [@test.attr2][@test.attr3]) + | _ -> assert false;; (******************) (* Labeled tuples *) +let z, punned = 4, 5 +let x_must_be_even _ = assert false +exception Odd + let x = (~x:1, ~y:2) let x = ((~x:1, ~y:2) [@test.attr]) let _ = ( ~x: 5, 2, ~z, ~(punned:int)) diff --git a/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference b/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference new file mode 100644 index 00000000000..b08f14a0f46 --- /dev/null +++ b/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference @@ -0,0 +1,9 @@ +File "source_jane_street.ml", line 27, characters 2-18: +27 | type t : float64 + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "jane.erasable.layouts.annot" attribute cannot appear in this context + +File "source_jane_street.ml", line 27, characters 2-18: +27 | type t : float64 + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "jane.erasable.layouts" attribute cannot appear in this context diff --git a/ocaml/testsuite/tests/parsetree/test_ppx.ml b/ocaml/testsuite/tests/parsetree/test_ppx.ml new file mode 100644 index 00000000000..3ce00588e87 --- /dev/null +++ b/ocaml/testsuite/tests/parsetree/test_ppx.ml @@ -0,0 +1,19 @@ +(* TEST +readonly_files = "source_jane_street.ml ppx_no_op.ml" +include ocamlcommon +* setup-ocamlc.byte-build-env +** ocamlc.byte +program = "${test_build_directory}/ppx_no_op.exe" +all_modules = "ppx_no_op.ml" +*** ocamlc.byte +module = "source_jane_street.ml" +flags = "-I ${test_build_directory} \ + -w -26 \ + -extension layouts \ + -extension comprehensions \ + -ppx ${program}" +**** check-ocamlc.byte-output +*) + +(* This test ensures that Jane Street syntax continues to be + handled properly by the compiler even after applying a PPX rewriter. *) From 74391379fbc60f4d510182c8ef2e65ee098fd3d3 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 12 Dec 2023 12:33:38 -0500 Subject: [PATCH 2/2] Fix bug --- ocaml/parsing/ast_iterator.ml | 11 +++++++++-- ocaml/parsing/ast_mapper.ml | 18 ++++++++++++++---- .../tests/parsetree/source_jane_street.ml | 2 ++ .../parsetree/test_ppx.compilers.reference | 9 --------- 4 files changed, 25 insertions(+), 15 deletions(-) diff --git a/ocaml/parsing/ast_iterator.ml b/ocaml/parsing/ast_iterator.ml index b94d81839ac..dd3c4a20e95 100644 --- a/ocaml/parsing/ast_iterator.ml +++ b/ocaml/parsing/ast_iterator.ml @@ -178,12 +178,19 @@ module T = struct | Ptyp_extension x -> sub.extension sub x let iter_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; + ({ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private = _; ptype_manifest; ptype_attributes; - ptype_loc} = + ptype_loc} as ty_decl) = + let ptype_attributes = + match Jane_syntax.Layouts.of_type_declaration ty_decl with + | Some (jkind, attrs) -> + iter_loc_txt sub sub.jkind_annotation jkind; + attrs + | None -> ptype_attributes + in iter_loc sub ptype_name; List.iter (iter_fst (sub.typ sub)) ptype_params; List.iter diff --git a/ocaml/parsing/ast_mapper.ml b/ocaml/parsing/ast_mapper.ml index d63618eeb82..75cc14f6c97 100644 --- a/ocaml/parsing/ast_mapper.ml +++ b/ocaml/parsing/ast_mapper.ml @@ -217,22 +217,32 @@ module T = struct | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; + ({ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; - ptype_loc} = + ptype_loc} as tyd) = let loc = sub.location sub ptype_loc in + let jkind, ptype_attributes = + match Jane_syntax.Layouts.of_type_declaration tyd with + | None -> None, ptype_attributes + | Some (jkind, attributes) -> + let jkind = map_loc_txt sub sub.jkind_annotation jkind in + Some jkind, attributes + in let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) + Jane_syntax.Layouts.type_declaration_of ~loc ~attrs (map_loc sub ptype_name) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:ptype_private ~cstrs:(List.map (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) ptype_cstrs) ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~manifest:(map_opt (sub.typ sub) ptype_manifest) + ~jkind + ~docs:Docstrings.empty_docs + ~text:None let map_type_kind sub = function | Ptype_abstract -> Ptype_abstract diff --git a/ocaml/testsuite/tests/parsetree/source_jane_street.ml b/ocaml/testsuite/tests/parsetree/source_jane_street.ml index ed347f18694..98be808b3ed 100644 --- a/ocaml/testsuite/tests/parsetree/source_jane_street.ml +++ b/ocaml/testsuite/tests/parsetree/source_jane_street.ml @@ -25,6 +25,8 @@ let f (type a : immediate) (type b : immediate) module type S_for_layouts = sig type t : float64 + + type variant = A : ('a : immediate). 'a -> variant end;; type ('a : immediate) for_layouts = 'a;; diff --git a/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference b/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference index b08f14a0f46..e69de29bb2d 100644 --- a/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference +++ b/ocaml/testsuite/tests/parsetree/test_ppx.compilers.reference @@ -1,9 +0,0 @@ -File "source_jane_street.ml", line 27, characters 2-18: -27 | type t : float64 - ^^^^^^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "jane.erasable.layouts.annot" attribute cannot appear in this context - -File "source_jane_street.ml", line 27, characters 2-18: -27 | type t : float64 - ^^^^^^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "jane.erasable.layouts" attribute cannot appear in this context