change to have two explicit injectable args instead

Author: zth

compiler/ml/lambda.ml

@@ -17,8 +17,8 @@ type loc_kind =
   | Loc_FILE
   | Loc_LINE
   | Loc_MODULE
-  | Loc_MODULE_PATH
-  | Loc_VALUE_PATH
+  | Loc_SOURCE_LOC_VALUE_PATH
+  | Loc_SOURCE_LOC_POS
   | Loc_LOC
   | Loc_POS
 
@@ -707,7 +707,9 @@ let raise_kind = function
 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
@@ -724,11 +726,18 @@ let lam_of_loc ?(root_path : Path.t option)
              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 -> (
+  | 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 ->

compiler/ml/lambda.mli

@@ -21,8 +21,8 @@ type loc_kind =
   | Loc_FILE
   | Loc_LINE
   | Loc_MODULE
-  | Loc_MODULE_PATH
-  | Loc_VALUE_PATH
+  | Loc_SOURCE_LOC_VALUE_PATH
+  | Loc_SOURCE_LOC_POS
   | Loc_LOC
   | Loc_POS
 

compiler/ml/predef.ml

@@ -51,7 +51,9 @@ and ident_result = ident_create "result"
 
 and ident_dict = ident_create "dict"
 
-and ident_source_loc = ident_create "sourceLoc"
+and ident_source_loc_pos = ident_create "sourceLocPos"
+
+and ident_source_loc_value_path = ident_create "sourceLocValuePath"
 
 and ident_bigint = ident_create "bigint"
 
@@ -100,7 +102,9 @@ and path_result = Pident ident_result
 
 and path_dict = Pident ident_dict
 
-and path_source_loc = Pident ident_source_loc
+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
 
@@ -322,36 +326,6 @@ 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]));
-               (* __MODULE_PATH__ *)
-               mk_field "modulePath" type_string;
-               (* __VALUE_PATH__ *)
-               mk_field "valuePath" type_string;
-             ],
-             Record_regular ));
-    }
   and decl_uncurried =
     let tvar1 = newgenvar () in
     {
@@ -436,7 +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 decl_source_loc
+  |> 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,7 +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 : 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,8 +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_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

@@ -247,8 +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);
+      ("%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));

compiler/ml/typecore.ml

@@ -2223,42 +2223,36 @@ 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
+type injectable_source_loc_arg = ValuePath | Pos
 
-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 rec find_injectable_source_loc_args ?(found = []) t =
+  match t.desc with
+  | Tarrow (Labelled n, {desc = Tconstr (p, [], _)}, next, _, _)
+    when Path.same p Predef.path_source_loc_pos ->
+    (Pos, n) :: find_injectable_source_loc_args ~found next
+  | Tarrow (Labelled n, {desc = Tconstr (p, [], _)}, next, _, _)
+    when 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_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
+  match find_injectable_source_loc_args exp_type with
+  | [] -> sargs
+  | injectable_args ->
+    (* TODO: Error on args already being supplied *)
     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__";
-              mk_source_loc_field "modulePath" "__MODULE_PATH__";
-              mk_source_loc_field "valuePath" "__VALUE_PATH__";
-            ]
-            None );
-      ]
+    @ (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

runtime/Pervasives.res

@@ -34,8 +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 __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,8 +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 __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,8 +19,8 @@ external __LOC__: string = "%loc_LOC"
 external __MODULE__: 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 __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"