Skip to content

Fix layout annotation encoding to work better with ppxlib #2234

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Jan 25, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions ocaml/parsing/jane_syntax.ml
Original file line number Diff line number Diff line change
Expand Up @@ -211,7 +211,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) :
let structure_item_of_none =
{ pstr_desc =
Pstr_attribute
{ attr_name = Location.mknoloc "none";
{ attr_name = Location.mknoloc "jane.none";
attr_payload = PStr [];
attr_loc = Location.none
};
Expand Down Expand Up @@ -278,7 +278,8 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) :
| _ -> raise Unexpected

let is_none_structure_item = function
| { pstr_desc = Pstr_attribute { attr_name = { txt = "none" } } } ->
| { pstr_desc = Pstr_attribute { attr_name = { txt = "jane.none" } } }
->
true
| _ -> false

Expand Down
3 changes: 3 additions & 0 deletions ocaml/testsuite/tests/parsetree/source_jane_street.ml
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
let f (type a : immediate) (x : a) = x;;
let f (type (a : immediate)) (x : a) = x;;
let f (type (a : immediate) (b : immediate)) (x : a) = x;;
let f (type (a : immediate) (b : immediate) c) (x : a) = x;;

let f y (type a : immediate) (x : a) = x;;
let f y (type (a : immediate)) (x : a) = x;;
Expand All @@ -17,6 +18,8 @@ let f y (type (a : immediate) (b : immediate)) (x : a) = x;;
let f y (type a : immediate) = y;;
let f y (type (a : immediate)) = y;;
let f y (type (a : immediate) (b : immediate)) = y;;
let f y (type (a : immediate) (b : immediate) c) = y;;


(* Just newtypes, no value parameters *)
let f (type a : immediate) (type b : immediate)
Expand Down
44 changes: 38 additions & 6 deletions ocaml/testsuite/tests/parsetree/test.ml
Original file line number Diff line number Diff line change
Expand Up @@ -61,7 +61,7 @@ let test parse_fun pprint print map filename ~extra_checks =
| ast ->
let str = to_string pprint ast in
begin
match extra_checks str with
match extra_checks (to_string print ast) str with
| Ok () -> ()
| Error reason ->
Printf.printf "%s: FAIL, %s\n" filename reason;
Expand Down Expand Up @@ -112,7 +112,7 @@ let rec process path ~extra_checks =
path
~extra_checks

let process ?(extra_checks = fun _ -> Ok ()) text = process text ~extra_checks
let process ?(extra_checks = fun _ _ -> Ok ()) text = process text ~extra_checks

(* Produce an error if any attribute/extension node does not start with the
text prefix.
Expand All @@ -128,7 +128,7 @@ let process ?(extra_checks = fun _ -> Ok ()) text = process text ~extra_checks
We've chosen to keep those constructs out of the test file in preference
to updating this logic to properly handle them (which is hard).
*)
let check_all_attributes_and_extensions_start_with text ~prefix =
let check_all_printed_attributes_and_extensions_start_with text ~prefix =
let check introduction_string =
String.split_on_char '[' text
|> List.for_all (fun s ->
Expand All @@ -146,14 +146,46 @@ let check_all_attributes_and_extensions_start_with text ~prefix =
prefix)
;;

let check_all_ast_attributes_and_extensions_start_with raw_parsetree_str ~prefixes =
(* Sadly can't use Ast_mapper here because it decodes Jane Syntax by default and
we will need quite a bit of code duplication for it to work for this use case. *)
let check introduction_string =
Misc.Stdlib.String.split_on_string ~split_on:(introduction_string ^ " \"")
raw_parsetree_str
|> List.tl
|> List.for_all (fun s ->
List.exists
(fun prefix -> String.starts_with s ~prefix)
prefixes)
in
if check "extension" && check "attribute"
then Ok ()
else
Error
(Printf.sprintf
"Printast produced an extension node or attribute that doesn't \
begin with one of [%s]"
(String.concat ", " prefixes))
;;

let () =
process "source.ml";
Language_extension.enable_maximal ();
process "source_jane_street.ml" ~extra_checks:(fun text ->
(* Check that printing Jane Street language extensions produces no more
process "source_jane_street.ml" ~extra_checks:(fun raw_parsetree_str text ->
(* Additionally check that:

1. Jane Street language extensions only use "extension." and "jane." prefixed
attributes and exntensions for its parsetree encoding. This is important for
ppx support.

2. Printing Jane Street language extensions produces no more
attributes or extension nodes than the input program, all of whose
attributes begin with "test". This ensures that Jane Syntax attributes
aren't printed.
*)
check_all_attributes_and_extensions_start_with text ~prefix:"test");
Result.bind
(check_all_ast_attributes_and_extensions_start_with raw_parsetree_str
~prefixes:["extension."; "jane."; "test."])
(fun () -> check_all_printed_attributes_and_extensions_start_with text
~prefix:"test"));
;;