[PoC] Injectable source loc arg

compiler/frontend/ast_exp_extension.ml

@@ -26,6 +26,10 @@ open Ast_helper
 let handle_extension e (self : Bs_ast_mapper.mapper)
     (({txt; loc}, payload) : Parsetree.extension) =
   match txt with
+  | "autoFill" ->
+    Exp.apply ~loc
+      (Exp.ident ~loc {txt = Longident.parse "Obj.magic"; loc})
+      [(Nolabel, Exp.construct ~loc {txt = Longident.parse "()"; loc} None)]
   | "todo" ->
     let todo_message =
       match Ast_payload.is_single_string payload with

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 {
@@ -697,9 +704,12 @@ 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 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
@@ -716,6 +726,28 @@ 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 -> (
+    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_SOURCE_LOC_VALUE_PATH
+  | Loc_SOURCE_LOC_POS
+  | 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

@@ -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_lazy_t = ident_create "lazy_t"
@@ -98,6 +102,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_lazy_t = Pident ident_lazy_t
@@ -402,6 +410,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

@@ -46,6 +46,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_lazy_t : 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,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_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));
@@ -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

@@ -2223,6 +2223,49 @@ let not_function env ty =
   let ls, tvar = list_labels env ty in
   ls = [] && not tvar
 
+type injectable_source_loc_arg = ValuePath | Pos
+
+let rec find_injectable_source_loc_args ?(found = []) t =
+  match t.desc with
+  | Tarrow
+      ( Optional n,
+        {desc = Tconstr (opt_p, [{desc = Tconstr (p, [], _)}], _)},
+        next,
+        _,
+        _ )
+    when Path.same opt_p Predef.path_option
+         && Path.same p Predef.path_source_loc_pos ->
+    (Pos, n) :: find_injectable_source_loc_args ~found next
+  | Tarrow
+      ( Optional n,
+        {desc = Tconstr (opt_p, [{desc = Tconstr (p, [], _)}], _)},
+        next,
+        _,
+        _ )
+    when Path.same opt_p Predef.path_option
+         && Path.same p Predef.path_source_loc_value_path ->
+    (ValuePath, n) :: find_injectable_source_loc_args ~found next
+  | Tarrow (_, _, t, _, _) -> find_injectable_source_loc_args t
+  | _ -> found
+
+let expand_injectable_args ~(apply_expr : Parsetree.expression) ~exp_type
+    (sargs : sargs) =
+  match find_injectable_source_loc_args exp_type with
+  | [] -> sargs
+  | injectable_args ->
+    (* TODO: Error on args already being supplied *)
+    sargs
+    @ (injectable_args
+      |> List.map (fun (t, n) ->
+             ( Labelled (Location.mknoloc n),
+               Ast_helper.Exp.ident
+                 ~loc:{apply_expr.pexp_loc with loc_ghost = true}
+                 (Location.mknoloc
+                    (Longident.Lident
+                       (match t with
+                       | ValuePath -> "__SOURCE_LOC_VALUE_PATH__"
+                       | Pos -> "__SOURCE_LOC_POS__"))) )))
+
 type lazy_args =
   (Asttypes.Noloc.arg_label * (unit -> Typedtree.expression) option) list
 
@@ -2412,7 +2455,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     let args, ty_res, fully_applied =
       match translate_unified_ops env funct sargs with
       | Some (targs, result_type) -> (targs, result_type, true)
-      | None -> type_application ?type_clash_context total_app env funct sargs
+      | None ->
+        type_application ~apply_expr:sexp ?type_clash_context total_app env
+          funct sargs
     in
     end_def ();
     unify_var env (newvar ()) funct.exp_type;
@@ -3447,8 +3492,11 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression)
     | _ -> None)
   | _ -> None
 
-and type_application ?type_clash_context total_app env funct (sargs : sargs) :
-    targs * Types.type_expr * bool =
+and type_application ?type_clash_context ~apply_expr total_app env funct
+    (sargs : sargs) : targs * Types.type_expr * bool =
+  let sargs =
+    expand_injectable_args ~apply_expr ~exp_type:funct.exp_type sargs
+  in
   let result_type omitted ty_fun =
     List.fold_left
       (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok, 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 __SOURCE_LOC_VALUE_PATH__: sourceLocValuePath = "%loc_SOURCE_LOC_VALUE_PATH"
+external __SOURCE_LOC_POS__: sourceLocPos = "%loc_SOURCE_LOC_POS"
 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 __SOURCE_LOC_VALUE_PATH__: sourceLocValuePath = "%loc_SOURCE_LOC_VALUE_PATH"
+external __SOURCE_LOC_POS__: sourceLocPos = "%loc_SOURCE_LOC_POS"
 external __POS__: (string, int, int, int) = "%loc_POS"
 
 external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC"

tests/tests/src/test_per.res

@@ -19,6 +19,8 @@ external __LOC__: string = "%loc_LOC"
 external __MODULE__: string = "%loc_FILE"
 external __LINE__: int = "%loc_LINE"
 external __MODULE__: string = "%loc_MODULE"
+external __SOURCE_LOC_VALUE_PATH__: sourceLocValuePath = "%loc_SOURCE_LOC_VALUE_PATH"
+external __SOURCE_LOC_POS__: sourceLocPos = "%loc_SOURCE_LOC_POS"
 external __POS__: (string, int, int, int) = "%loc_POS"
 
 external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC"