add __MODULE_PATH__ and __VALUE_PATH__ magic constants, and hook them up to injectable sourceLoc

Author: zth

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_MODULE_PATH
+  | Loc_VALUE_PATH
+  | Loc_LOC
+  | Loc_POS
 
 type tag_info =
   | Blk_constructor of {
@@ -697,7 +704,8 @@ 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_ident : Ident.t option) kind loc =
   let loc_start = loc.Location.loc_start in
   let file, lnum, cnum = Location.get_pos_info loc_start in
   let file = Filename.basename file in
@@ -716,6 +724,21 @@ let lam_of_loc kind loc =
              Const_base (Const_int enum);
            ] ))
   | Loc_FILE -> Lconst (Const_immstring file)
+  | Loc_MODULE_PATH -> (
+    match root_path with
+    | None -> Lconst (Const_immstring "<none>")
+    | Some path -> Lconst (Const_immstring (Path.name path)))
+  | Loc_VALUE_PATH -> (
+    match root_path with
+    | None -> Lconst (Const_immstring "<none>")
+    | Some path ->
+      Lconst
+        (Const_immstring
+           (Path.name path
+           ^
+           match current_value_ident with
+           | None -> ""
+           | Some ident -> "." ^ Ident.name ident)))
   | 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_MODULE_PATH
+  | Loc_VALUE_PATH
+  | Loc_LOC
+  | Loc_POS
 
 type tag_info =
   | Blk_constructor of {
@@ -415,4 +422,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_ident:Ident.t ->
+  loc_kind ->
+  Location.t ->
+  lambda

compiler/ml/predef.ml

@@ -345,6 +345,10 @@ let common_initial_env add_type add_extension empty_env =
                (* __POS__ *)
                mk_field "pos"
                  (newgenty (Ttuple [type_string; type_int; type_int; type_int]));
+               (* __MODULE_PATH__ *)
+               mk_field "modulePath" type_string;
+               (* __VALUE_PATH__ *)
+               mk_field "valuePath" type_string;
              ],
              Record_regular ));
     }

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_MODULE_PATH -> "loc_MODULE_PATH"
+  | Loc_VALUE_PATH -> "loc_VALUE_PATH"
   | Loc_POS -> "loc_POS"
   | Loc_LOC -> "loc_LOC"
 

compiler/ml/translcore.ml

@@ -34,6 +34,9 @@ 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_ident = ref None
+
 (* Compile an exception/extension definition *)
 
 let transl_extension_constructor env path ext =
@@ -244,6 +247,8 @@ let primitives_table =
       ("%loc_LINE", Ploc Loc_LINE);
       ("%loc_POS", Ploc Loc_POS);
       ("%loc_MODULE", Ploc Loc_MODULE);
+      ("%loc_MODULE_PATH", Ploc Loc_MODULE_PATH);
+      ("%loc_VALUE_PATH", Ploc Loc_VALUE_PATH);
       (* BEGIN Triples for  ref data type *)
       ("%makeref", Pmakeblock Lambda.ref_tag_info);
       ("%refset", Psetfield (0, Lambda.ref_field_set_info));
@@ -448,7 +453,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 ?current_value_ident:!current_value_ident
+        ?root_path:!current_root_path kind loc
+    in
     match p.prim_arity with
     | 0 -> lam
     | 1 ->
@@ -741,9 +749,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 ?current_value_ident:!current_value_ident
+        ?root_path:!current_root_path kind e.exp_loc
     | Ploc kind, [arg1] ->
-      let lam = lam_of_loc kind arg1.exp_loc in
+      let lam =
+        lam_of_loc ?current_value_ident:!current_value_ident
+          ?root_path:!current_root_path kind arg1.exp_loc
+      in
       Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc)
     | Ploc _, _ -> assert false
     | _, _ -> (
@@ -1055,6 +1068,21 @@ and transl_function loc partial param case =
       is_base_type exp_env exp_type Predef.path_unit )
 
 and transl_let rec_flag pat_expr_list body =
+  let old_value_ident = !current_value_ident in
+
+  let binding_name =
+    pat_expr_list |> List.rev
+    |> List.find_map (fun {vb_pat} ->
+           match vb_pat.pat_desc with
+           | Tpat_var (id, _) -> Some id
+           | _ -> None)
+  in
+  current_value_ident := binding_name;
+  let res = transl_let_inner rec_flag pat_expr_list body in
+  current_value_ident := old_value_ident;
+  res
+
+and transl_let_inner rec_flag pat_expr_list body =
   match rec_flag with
   | Nonrecursive ->
     let rec transl = function

compiler/ml/translcore.mli

@@ -41,3 +41,6 @@ val transl_module :
   Typedtree.module_expr ->
   Lambda.lambda)
   ref
+
+val current_root_path : Path.t option ref
+val current_value_ident : Ident.t option ref

compiler/ml/translmod.ml

@@ -253,6 +253,13 @@ let rec compile_functor mexp coercion root_path loc =
 
 (* Compile a module expression *)
 and transl_module cc rootpath mexp =
+  let current_root_path = !Translcore.current_root_path in
+  Translcore.current_root_path := rootpath;
+  let res = transl_module_inner cc rootpath mexp in
+  Translcore.current_root_path := current_root_path;
+  res
+
+and transl_module_inner 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

compiler/ml/typecore.ml

@@ -2254,6 +2254,8 @@ let expand_injectable_args ~(apply_expr : Parsetree.expression) ~exp_type
               mk_source_loc_field "filename" "__FILE__";
               mk_source_loc_field "module_" "__MODULE__";
               mk_source_loc_field "pos" "__POS__";
+              mk_source_loc_field "modulePath" "__MODULE_PATH__";
+              mk_source_loc_field "valuePath" "__VALUE_PATH__";
             ]
             None );
       ]

runtime/Pervasives.res

@@ -34,6 +34,8 @@ external __LOC__: string = "%loc_LOC"
 external __FILE__: string = "%loc_FILE"
 external __LINE__: int = "%loc_LINE"
 external __MODULE__: string = "%loc_MODULE"
+external __MODULE_PATH__: string = "%loc_MODULE_PATH"
+external __VALUE_PATH__: string = "%loc_VALUE_PATH"
 external __POS__: (string, int, int, int) = "%loc_POS"
 
 external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC"

runtime/Pervasives_mini.res

@@ -7,6 +7,8 @@ external __LOC__: string = "%loc_LOC"
 external __FILE__: string = "%loc_FILE"
 external __LINE__: int = "%loc_LINE"
 external __MODULE__: string = "%loc_MODULE"
+external __MODULE_PATH__: string = "%loc_MODULE_PATH"
+external __VALUE_PATH__: string = "%loc_VALUE_PATH"
 external __POS__: (string, int, int, int) = "%loc_POS"
 
 external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC"