Implement autofilled source loc magic constants

CHANGELOG.md

@@ -22,6 +22,7 @@
 
 - Reanalyze: add glob pattern support for suppress/unsuppress configurations (e.g., `"src/generated/**"`). https://github.com/rescript-lang/rescript/pull/8277
 - Add optional `~locales` and `~options` parameters to `String.localeCompare`. https://github.com/rescript-lang/rescript/pull/8287
+- Add new `sourceLocPos` and `sourceLocValuePath` magic constants, and allow them to be autoinjected from the call site into function arguments via `-allow-autofill-source-loc`. https://github.com/rescript-lang/rescript/pull/8303
 
 #### :bug: Bug fix
 

compiler/bsc/rescript_compiler_main.ml

@@ -336,6 +336,9 @@ let command_line_flags : (string * Bsc_args.spec * string) array =
     ( "-bs-noassertfalse",
       set Clflags.no_assert_false,
       "*internal*  no code for assert false" );
+    ( "-allow-autofill-source-loc",
+      set Clflags.allow_autofill_source_loc,
+      "*internal* Allow source-loc autofill for optional source-loc args" );
     ( "-noassert",
       set Clflags.noassert,
       "*internal* Do not compile assertion checks" );

compiler/ml/clflags.ml

@@ -46,6 +46,8 @@ and ignore_parse_errors = ref false (* -ignore-parse-errors *)
 
 let dont_write_files = ref false (* set to true under ocamldoc *)
 
+let allow_autofill_source_loc = ref false
+
 let reset_dump_state () =
   dump_source := false;
   dump_parsetree := false;

compiler/ml/clflags.mli

@@ -22,6 +22,7 @@ val dump_typedtree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
 val dont_write_files : bool ref
+val allow_autofill_source_loc : bool ref
 val keep_locs : bool ref
 val only_parse : bool ref
 val ignore_parse_errors : bool ref

compiler/ml/lambda.ml

@@ -13,7 +13,14 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS
+type loc_kind =
+  | Loc_FILE
+  | Loc_LINE
+  | Loc_MODULE
+  | Loc_SOURCE_LOC_VALUE_PATH
+  | Loc_SOURCE_LOC_POS
+  | Loc_LOC
+  | Loc_POS
 
 type tag_info =
   | Blk_constructor of {
@@ -699,13 +706,23 @@ let raise_kind = function
   | Raise_regular -> "raise"
   | Raise_reraise -> "reraise"
 
-let lam_of_loc kind loc =
+let lam_of_loc ?(root_path : Path.t option) ?(current_value_path = []) kind loc
+    =
   let loc_start = loc.Location.loc_start in
+  let loc_end = loc.loc_end in
   let file, lnum, cnum = Location.get_pos_info loc_start in
+  let _, end_lnum, end_cnum = Location.get_pos_info loc_end in
   let file = Filename.basename file in
   let enum =
     loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum
   in
+  let module_path =
+    match root_path with
+    | Some path -> Path.name path
+    | None ->
+      let name = Env.get_unit_name () in
+      if name = "" then Filename.remove_extension file else name
+  in
   match kind with
   | Loc_POS ->
     Lconst
@@ -718,6 +735,24 @@ let lam_of_loc kind loc =
              Const_base (Const_int enum);
            ] ))
   | Loc_FILE -> Lconst (Const_immstring file)
+  | Loc_SOURCE_LOC_POS ->
+    Lconst
+      (Const_immstring
+         ([
+            file;
+            string_of_int lnum;
+            string_of_int cnum;
+            string_of_int end_lnum;
+            string_of_int end_cnum;
+          ]
+         |> String.concat ";"))
+  | Loc_SOURCE_LOC_VALUE_PATH ->
+    let value_path =
+      match current_value_path with
+      | [] -> module_path
+      | _ -> String.concat "." (module_path :: current_value_path)
+    in
+    Lconst (Const_immstring value_path)
   | Loc_MODULE ->
     let filename = Filename.basename file in
     let name = Env.get_unit_name () in

compiler/ml/lambda.mli

@@ -17,7 +17,14 @@
 
 open Asttypes
 
-type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS
+type loc_kind =
+  | Loc_FILE
+  | Loc_LINE
+  | Loc_MODULE
+  | Loc_SOURCE_LOC_VALUE_PATH
+  | Loc_SOURCE_LOC_POS
+  | Loc_LOC
+  | Loc_POS
 
 type tag_info =
   | Blk_constructor of {
@@ -419,4 +426,9 @@ val is_guarded : lambda -> bool
 val patch_guarded : lambda -> lambda -> lambda
 
 val raise_kind : raise_kind -> string
-val lam_of_loc : loc_kind -> Location.t -> lambda
+val lam_of_loc :
+  ?root_path:Path.t ->
+  ?current_value_path:string list ->
+  loc_kind ->
+  Location.t ->
+  lambda

compiler/ml/predef.ml

@@ -51,6 +51,10 @@ and ident_result = ident_create "result"
 
 and ident_dict = ident_create "dict"
 
+and ident_source_loc_pos = ident_create "sourceLocPos"
+
+and ident_source_loc_value_path = ident_create "sourceLocValuePath"
+
 and ident_bigint = ident_create "bigint"
 
 and ident_string = ident_create "string"
@@ -67,6 +71,9 @@ let type_is_builtin_path_but_option (p : Path.t) : test =
   match p with
   | Pident {stamp} when stamp = ident_option.stamp -> For_sure_no
   | Pident {stamp} when stamp = ident_unit.stamp -> For_sure_no
+  | Pident {stamp} when stamp = ident_source_loc_pos.stamp -> For_sure_yes
+  | Pident {stamp} when stamp = ident_source_loc_value_path.stamp ->
+    For_sure_yes
   | Pident {stamp} when stamp >= ident_int.stamp && stamp <= ident_promise.stamp
     ->
     For_sure_yes
@@ -94,6 +101,10 @@ and path_result = Pident ident_result
 
 and path_dict = Pident ident_dict
 
+and path_source_loc_pos = Pident ident_source_loc_pos
+
+and path_source_loc_value_path = Pident ident_source_loc_value_path
+
 and path_bigint = Pident ident_bigint
 
 and path_string = Pident ident_string
@@ -371,6 +382,8 @@ let common_initial_env add_type add_extension empty_env =
   |> add_type ident_array decl_array
   |> add_type ident_list decl_list
   |> add_type ident_dict decl_dict
+  |> add_type ident_source_loc_pos decl_abstr
+  |> add_type ident_source_loc_value_path decl_abstr
   |> add_type ident_unknown decl_unknown
   |> add_exception ident_undefined_recursive_module
        [newgenty (Ttuple [type_string; type_int; type_int])]

compiler/ml/predef.mli

@@ -45,6 +45,8 @@ val path_list : Path.t
 val path_option : Path.t
 val path_result : Path.t
 val path_dict : Path.t
+val path_source_loc_pos : Path.t
+val path_source_loc_value_path : Path.t
 
 val path_bigint : Path.t
 val path_extension_constructor : Path.t

compiler/ml/printlambda.ml

@@ -55,6 +55,8 @@ let string_of_loc_kind = function
   | Loc_FILE -> "loc_FILE"
   | Loc_LINE -> "loc_LINE"
   | Loc_MODULE -> "loc_MODULE"
+  | Loc_SOURCE_LOC_VALUE_PATH -> "loc_SOURCE_LOC_VALUE_PATH"
+  | Loc_SOURCE_LOC_POS -> "loc_SOURCE_LOC_POS"
   | Loc_POS -> "loc_POS"
   | Loc_LOC -> "loc_LOC"
 

compiler/ml/translcore.ml

@@ -34,6 +34,21 @@ let transl_module =
     (fun _cc _rootpath _modl -> assert false
       : module_coercion -> Path.t option -> module_expr -> lambda)
 
+let current_root_path = ref None
+let current_value_path = ref []
+
+let with_current_value_path pat f =
+  let path_segment =
+    match pat.pat_desc with
+    | Tpat_var (id, _) -> Some (Ident.name id)
+    | Tpat_alias (_, id, _) -> Some (Ident.name id)
+    | _ -> None
+  in
+  match path_segment with
+  | None -> f ()
+  | Some name ->
+    Ext_ref.protect current_value_path (!current_value_path @ [name]) f
+
 (* Compile an exception/extension definition *)
 
 let transl_extension_constructor env path ext =
@@ -244,6 +259,8 @@ let primitives_table =
       ("%loc_LINE", Ploc Loc_LINE);
       ("%loc_POS", Ploc Loc_POS);
       ("%loc_MODULE", Ploc Loc_MODULE);
+      ("%loc_SOURCE_LOC_VALUE_PATH", Ploc Loc_SOURCE_LOC_VALUE_PATH);
+      ("%loc_SOURCE_LOC_POS", Ploc Loc_SOURCE_LOC_POS);
       (* BEGIN Triples for  ref data type *)
       ("%makeref", Pmakeblock Lambda.ref_tag_info);
       ("%refset", Psetfield (0, Lambda.ref_field_set_info));
@@ -449,7 +466,10 @@ let transl_primitive loc p env ty =
   in
   match prim with
   | Ploc kind -> (
-    let lam = lam_of_loc kind loc in
+    let lam =
+      lam_of_loc ?root_path:!current_root_path
+        ~current_value_path:!current_value_path kind loc
+    in
     match p.prim_arity with
     | 0 -> lam
     | 1 ->
@@ -743,9 +763,14 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
         | _ -> k
       in
       wrap (Lprim (Praise k, [targ], e.exp_loc))
-    | Ploc kind, [] -> lam_of_loc kind e.exp_loc
+    | Ploc kind, [] ->
+      lam_of_loc ?root_path:!current_root_path
+        ~current_value_path:!current_value_path kind e.exp_loc
     | Ploc kind, [arg1] ->
-      let lam = lam_of_loc kind arg1.exp_loc in
+      let lam =
+        lam_of_loc ?root_path:!current_root_path
+          ~current_value_path:!current_value_path kind arg1.exp_loc
+      in
       Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc)
     | Ploc _, _ -> assert false
     | _, _ -> (
@@ -1076,7 +1101,7 @@ and transl_let rec_flag pat_expr_list body =
     let rec transl = function
       | [] -> body
       | {vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc} :: rem ->
-        let lam = transl_exp expr in
+        let lam = with_current_value_path pat (fun () -> transl_exp expr) in
         let lam = Translattribute.add_inline_attribute lam vb_loc attr in
         Matching.for_let pat.pat_loc lam pat (transl rem)
     in
@@ -1092,7 +1117,7 @@ and transl_let rec_flag pat_expr_list body =
            Only variables are allowed as left-hand side of `let rec'
         *)
       in
-      let lam = transl_exp expr in
+      let lam = with_current_value_path pat (fun () -> transl_exp expr) in
       let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in
       (id, lam)
     in

compiler/ml/translcore.mli

@@ -34,6 +34,8 @@ val transl_primitive :
 val transl_extension_constructor :
   Env.t -> Path.t option -> Typedtree.extension_constructor -> Lambda.lambda
 
+val current_root_path : Path.t option ref
+
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 val transl_module :
   (Typedtree.module_coercion ->

compiler/ml/translmod.ml

@@ -254,35 +254,38 @@ let rec compile_functor mexp coercion root_path loc =
 
 (* Compile a module expression *)
 and transl_module cc rootpath mexp =
-  List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes;
-  let loc = mexp.mod_loc in
-  match mexp.mod_type with
-  | Mty_alias (Mta_absent, _) ->
-    apply_coercion loc Alias cc Lambda.lambda_module_alias
-  | _ -> (
-    match mexp.mod_desc with
-    | Tmod_ident (path, _) ->
-      apply_coercion loc Strict cc
-        (Lambda.transl_module_path ~loc mexp.mod_env path)
-    | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str)
-    | Tmod_functor _ -> compile_functor mexp cc rootpath loc
-    | Tmod_apply (funct, arg, ccarg) ->
-      let inlined_attribute, funct =
-        Translattribute.get_and_remove_inlined_attribute_on_module funct
-      in
-      apply_coercion loc Strict cc
-        (Lapply
-           {
-             ap_loc = loc;
-             ap_func = transl_module Tcoerce_none None funct;
-             ap_args = [transl_module ccarg None arg];
-             ap_inlined = inlined_attribute;
-             ap_transformed_jsx = false;
-           })
-    | Tmod_constraint (arg, _, _, ccarg) ->
-      transl_module (compose_coercions cc ccarg) rootpath arg
-    | Tmod_unpack (arg, _) ->
-      apply_coercion loc Strict cc (Translcore.transl_exp arg))
+  Ext_ref.protect Translcore.current_root_path rootpath (fun () ->
+      List.iter
+        (Translattribute.check_attribute_on_module mexp)
+        mexp.mod_attributes;
+      let loc = mexp.mod_loc in
+      match mexp.mod_type with
+      | Mty_alias (Mta_absent, _) ->
+        apply_coercion loc Alias cc Lambda.lambda_module_alias
+      | _ -> (
+        match mexp.mod_desc with
+        | Tmod_ident (path, _) ->
+          apply_coercion loc Strict cc
+            (Lambda.transl_module_path ~loc mexp.mod_env path)
+        | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str)
+        | Tmod_functor _ -> compile_functor mexp cc rootpath loc
+        | Tmod_apply (funct, arg, ccarg) ->
+          let inlined_attribute, funct =
+            Translattribute.get_and_remove_inlined_attribute_on_module funct
+          in
+          apply_coercion loc Strict cc
+            (Lapply
+               {
+                 ap_loc = loc;
+                 ap_func = transl_module Tcoerce_none None funct;
+                 ap_args = [transl_module ccarg None arg];
+                 ap_inlined = inlined_attribute;
+                 ap_transformed_jsx = false;
+               })
+        | Tmod_constraint (arg, _, _, ccarg) ->
+          transl_module (compose_coercions cc ccarg) rootpath arg
+        | Tmod_unpack (arg, _) ->
+          apply_coercion loc Strict cc (Translcore.transl_exp arg)))
 
 and transl_struct loc fields cc rootpath str =
   transl_structure loc fields cc rootpath str.str_final_env str.str_items