add injectable sourceLoc arg to functions

Author: zth

compiler/ml/predef.ml

@@ -51,6 +51,8 @@ and ident_result = ident_create "result"
 
 and ident_dict = ident_create "dict"
 
+and ident_source_loc = ident_create "sourceLoc"
+
 and ident_bigint = ident_create "bigint"
 
 and ident_lazy_t = ident_create "lazy_t"
@@ -98,6 +100,8 @@ and path_result = Pident ident_result
 
 and path_dict = Pident ident_dict
 
+and path_source_loc = Pident ident_source_loc
+
 and path_bigint = Pident ident_bigint
 
 and path_lazy_t = Pident ident_lazy_t
@@ -318,6 +322,32 @@ let common_initial_env add_type add_extension empty_env =
             ],
             Record_regular );
     }
+  and decl_source_loc =
+    {
+      decl_abstr with
+      type_kind =
+        (let mk_field name typ =
+           {
+             ld_id = ident_create name;
+             ld_attributes = [];
+             ld_loc = Location.none;
+             ld_mutable = Immutable;
+             ld_optional = false;
+             ld_type = typ;
+           }
+         in
+         Type_record
+           ( [
+               (* __FILE__ *)
+               mk_field "filename" type_string;
+               (* __MODULE__ *)
+               mk_field "module_" type_string;
+               (* __POS__ *)
+               mk_field "pos"
+                 (newgenty (Ttuple [type_string; type_int; type_int; type_int]));
+             ],
+             Record_regular ));
+    }
   and decl_uncurried =
     let tvar1 = newgenvar () in
     {
@@ -402,6 +432,7 @@ 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 decl_source_loc
   |> 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,7 @@ val path_list : Path.t
 val path_option : Path.t
 val path_result : Path.t
 val path_dict : Path.t
+val path_source_loc : Path.t
 
 val path_bigint : Path.t
 val path_lazy_t : Path.t

compiler/ml/typecore.ml

@@ -2223,6 +2223,41 @@ let not_function env ty =
   let ls, tvar = list_labels env ty in
   ls = [] && not tvar
 
+let rec find_injectable_source_loc_arg t =
+  match t.desc with
+  | Tarrow (Labelled n, {desc = Tconstr (p, [], _)}, _, _, _)
+    when Path.same p Predef.path_source_loc ->
+    Some n
+  | Tarrow (_, _, t, _, _) -> find_injectable_source_loc_arg t
+  | _ -> None
+
+let mk_source_loc_field ~parent_loc field_name ident_name =
+  ( Location.mknoloc (Longident.Lident field_name),
+    Ast_helper.Exp.ident
+      ~loc:{parent_loc with loc_ghost = true}
+      (Location.mknoloc (Longident.Lident ident_name)),
+    false )
+
+let expand_injectable_args ~(apply_expr : Parsetree.expression) ~exp_type
+    (sargs : sargs) =
+  match find_injectable_source_loc_arg exp_type with
+  | None -> sargs
+  | Some injectable_source_loc_arg_label_name ->
+    let mk_source_loc_field =
+      mk_source_loc_field ~parent_loc:apply_expr.pexp_loc
+    in
+    sargs
+    @ [
+        ( Labelled (Location.mknoloc injectable_source_loc_arg_label_name),
+          Ast_helper.Exp.record
+            [
+              mk_source_loc_field "filename" "__FILE__";
+              mk_source_loc_field "module_" "__MODULE__";
+              mk_source_loc_field "pos" "__POS__";
+            ]
+            None );
+      ]
+
 type lazy_args =
   (Asttypes.Noloc.arg_label * (unit -> Typedtree.expression) option) list
 
@@ -2412,7 +2447,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 +3484,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)))