flambda-backend: Set location on topmost Jane Syntax attribute (#1696)

* Demonstrate _none_ Location

* Fix bug and demonstrate via tests

Author: ncik-roberts

parsing/jane_syntax_parsing.ml

@@ -800,8 +800,8 @@ module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct
 
   let make_entire_jane_syntax ~loc feature ast =
     AST.with_location
-      (make_jane_syntax feature []
-         (Ast_helper.with_default_loc { loc with loc_ghost = true } ast))
+      (Ast_helper.with_default_loc { loc with loc_ghost = true } (fun () ->
+        make_jane_syntax feature [] (ast ())))
       loc
 
   (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *)

testsuite/tests/jane-modular-syntax/attribute_locations.ml

@@ -0,0 +1,70 @@
+(* TEST
+   include ocamlcommon *)
+
+let () = Language_extension.enable Comprehensions ();;
+
+ module Location_map = struct
+   include Map.Make (struct
+     type t = Location.t
+     let compare = compare
+  end)
+
+   let add_multi key data t =
+     update key (function
+       | None -> Some [data]
+       | Some x -> Some (data :: x))
+       t
+end
+
+let gather_attributes_by_location program_text =
+  let program_text_buf = Lexing.from_string program_text in
+  Lexing.set_filename program_text_buf "<no filename in test>";
+  let parsed = Parse.expression program_text_buf in
+  let attrs_by_location = ref Location_map.empty in
+  let record_attribute { Parsetree.attr_name; attr_loc } =
+    attrs_by_location :=
+       Location_map.add_multi attr_loc attr_name.txt !attrs_by_location
+  in
+   (* We can't use an [attribute] iterator because Jane Syntax attributes are
+      skipped by the default iterator. To undo this behavior, we instead override
+      the expression iterator to look at attributes literally.
+   *)
+   let expr iterator (x : Parsetree.expression) =
+     List.iter record_attribute x.pexp_attributes;
+     Ast_iterator.default_iterator.expr iterator { x with pexp_attributes = [] }
+   in
+   let iterator = { Ast_iterator.default_iterator with expr } in
+   iterator.expr iterator parsed;
+   !attrs_by_location
+;;
+
+let run_test program_text ~summary =
+  print_endline "---";
+  Printf.printf "Test: %s\n" summary;
+  print_endline "Program text:";
+  print_endline program_text;
+  print_endline "Attributes and their locations:";
+  let attributes_by_location = gather_attributes_by_location program_text in
+  Location_map.iter
+    (fun loc at_loc ->
+      let printf fmt = Format.fprintf Format.std_formatter fmt in
+      printf "\tAt location %a:\n" Location.print_loc loc;
+      List.iter (printf "\t\t%s\n") at_loc)
+    attributes_by_location
+;;
+
+let () =
+  run_test ~summary:"single Jane Syntax construct"
+    "[ x for x in [ 1; 2; 3 ]]"
+;;
+
+let () =
+  run_test ~summary:"multiple Jane Syntax constructs"
+    "let x1 = [ x for x in [ 1; 2; 3 ]] in\n\
+     let x2 = [ y for y = 1 to 100 ] in\n\
+     let x3 = [ y for y = 1 to 100 ] in\n\
+     let x4 = [ y for y = 100 downto 1 ] in\n\
+     let x6 = [| y for y = 100 downto 1 |] in\n\
+     let x7 = [ y for y = 1 to 100 when y = 50 ] in\n\
+     ()"
+;;

testsuite/tests/jane-modular-syntax/attribute_locations.reference

@@ -0,0 +1,59 @@
+---
+Test: single Jane Syntax construct
+Program text:
+[ x for x in [ 1; 2; 3 ]]
+Attributes and their locations:
+	At location File "<no filename in test>", line 1, characters 0-25:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.in
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions
+---
+Test: multiple Jane Syntax constructs
+Program text:
+let x1 = [ x for x in [ 1; 2; 3 ]] in
+let x2 = [ y for y = 1 to 100 ] in
+let x3 = [ y for y = 1 to 100 ] in
+let x4 = [ y for y = 100 downto 1 ] in
+let x6 = [| y for y = 100 downto 1 |] in
+let x7 = [ y for y = 1 to 100 when y = 50 ] in
+()
+Attributes and their locations:
+	At location File "<no filename in test>", line 1, characters 9-34:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.in
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions
+	At location File "<no filename in test>", line 2, characters 9-31:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.range.upto
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions
+	At location File "<no filename in test>", line 3, characters 9-31:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.range.upto
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions
+	At location File "<no filename in test>", line 4, characters 9-35:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.range.downto
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions
+	At location File "<no filename in test>", line 5, characters 9-37:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.for.range.downto
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.array.mutable
+		jane.non_erasable.comprehensions
+	At location File "<no filename in test>", line 6, characters 9-43:
+		jane.non_erasable.comprehensions.body
+		jane.non_erasable.comprehensions.when
+		jane.non_erasable.comprehensions.for.range.upto
+		jane.non_erasable.comprehensions.for
+		jane.non_erasable.comprehensions.list
+		jane.non_erasable.comprehensions