diff --git a/compiler/frontend/ast_exp_extension.ml b/compiler/frontend/ast_exp_extension.ml index 47405da03d..45411dd902 100644 --- a/compiler/frontend/ast_exp_extension.ml +++ b/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 diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 809c1164a7..d43f2a4724 100644 --- a/compiler/ml/lambda.ml +++ b/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 "") + | 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 diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index aecdec146f..8478e1929f 100644 --- a/compiler/ml/lambda.mli +++ b/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 diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index b64e3e23d1..f43aff035e 100644 --- a/compiler/ml/predef.ml +++ b/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])] diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli index 7919b802ee..dedcffd828 100644 --- a/compiler/ml/predef.mli +++ b/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 diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 682e05660a..21663f5037 100644 --- a/compiler/ml/printlambda.ml +++ b/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" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index db9624b841..6b20bbdb76 100644 --- a/compiler/ml/translcore.ml +++ b/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 diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index 1847a4883c..2755f73215 100644 --- a/compiler/ml/translcore.mli +++ b/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 diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index f815a536c0..0661af4fd2 100644 --- a/compiler/ml/translmod.ml +++ b/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 diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 4d14ddc3f2..bf64ba9624 100644 --- a/compiler/ml/typecore.ml +++ b/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))) diff --git a/runtime/Pervasives.res b/runtime/Pervasives.res index d657dd782f..0e33f2e695 100644 --- a/runtime/Pervasives.res +++ b/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" diff --git a/runtime/Pervasives_mini.res b/runtime/Pervasives_mini.res index 7049284417..a57742b0e8 100644 --- a/runtime/Pervasives_mini.res +++ b/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" diff --git a/tests/tests/src/test_per.res b/tests/tests/src/test_per.res index 1ecbd2f262..a5d8a26813 100644 --- a/tests/tests/src/test_per.res +++ b/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"