refactor

Author: zth

compiler/bsc/rescript_compiler_main.ml

@@ -12,24 +12,29 @@
 
 let absname = ref false
 
-external to_comment : Res_comment.t -> Error_message_utils.comment = "%identity"
-external from_comment : Error_message_utils.comment -> Res_comment.t
-  = "%identity"
+(* TODO: Maybe there's a better place to do this init. *)
+module Error_message_utils_support = struct
+  external to_comment : Res_comment.t -> Error_message_utils.Parser.comment
+    = "%identity"
+  external from_comment : Error_message_utils.Parser.comment -> Res_comment.t
+    = "%identity"
+end
 
 let () =
-  Error_message_utils.parse_source :=
+  Error_message_utils.Parser.parse_source :=
     fun source ->
       let res =
         Res_driver.parse_implementation_from_source ~for_printer:false
           ~display_filename:"<none>" ~source
       in
-      (res.parsetree, res.comments |> List.map to_comment)
+      ( res.parsetree,
+        res.comments |> List.map Error_message_utils_support.to_comment )
 
 let () =
-  Error_message_utils.reprint_source :=
+  Error_message_utils.Parser.reprint_source :=
     fun parsetree comments ->
       Res_printer.print_implementation parsetree
-        ~comments:(comments |> List.map from_comment)
+        ~comments:(comments |> List.map Error_message_utils_support.from_comment)
         ~width:80
 
 let set_abs_input_name sourcefile =

compiler/ml/error_message_utils.ml

@@ -1,11 +1,56 @@
 type extract_concrete_typedecl =
   Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration
 
-type comment
-let parse_source : (string -> Parsetree.structure * comment list) ref =
-  ref (fun _ -> ([], []))
-let reprint_source : (Parsetree.structure -> comment list -> string) ref =
-  ref (fun _ _ -> "")
+module Parser : sig
+  type comment
+
+  val parse_source : (string -> Parsetree.structure * comment list) ref
+
+  val reprint_source : (Parsetree.structure -> comment list -> string) ref
+
+  val parse_expr_at_loc :
+    Warnings.loc -> (Parsetree.expression * comment list) option
+
+  val reprint_expr_at_loc :
+    ?mapper:(Parsetree.expression -> Parsetree.expression option) ->
+    Warnings.loc ->
+    string option
+end = struct
+  type comment
+
+  let parse_source : (string -> Parsetree.structure * comment list) ref =
+    ref (fun _ -> ([], []))
+
+  let reprint_source : (Parsetree.structure -> comment list -> string) ref =
+    ref (fun _ _ -> "")
+
+  let extract_location_string ~src (loc : Location.t) =
+    let start_pos = loc.loc_start in
+    let end_pos = loc.loc_end in
+    let start_offset = start_pos.pos_cnum in
+    let end_offset = end_pos.pos_cnum in
+    String.sub src start_offset (end_offset - start_offset)
+
+  let parse_expr_at_loc loc =
+    (* TODO: Maybe cache later on *)
+    let src = Ext_io.load_file loc.Location.loc_start.pos_fname in
+    let sub_src = extract_location_string ~src loc in
+    let parsed, comments = !parse_source sub_src in
+    match parsed with
+    | [{Parsetree.pstr_desc = Pstr_eval (exp, _)}] -> Some (exp, comments)
+    | _ -> None
+
+  let wrap_in_structure exp =
+    [{Parsetree.pstr_desc = Pstr_eval (exp, []); pstr_loc = Location.none}]
+
+  let reprint_expr_at_loc ?(mapper = fun _ -> None) loc =
+    match parse_expr_at_loc loc with
+    | Some (exp, comments) -> (
+      match mapper exp with
+      | Some exp -> Some (!reprint_source (wrap_in_structure exp) comments)
+      | None -> None)
+    | None -> None
+end
 
 type type_clash_statement = FunctionCall
 type type_clash_context =
@@ -68,13 +113,6 @@ let is_record_type ~extract_concrete_typedecl ~env ty =
     | _ -> false
   with _ -> false
 
-let extract_location_string ~src (loc : Location.t) =
-  let start_pos = loc.loc_start in
-  let end_pos = loc.loc_end in
-  let start_offset = start_pos.pos_cnum in
-  let end_offset = end_pos.pos_cnum in
-  String.sub src start_offset (end_offset - start_offset)
-
 let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
     (bottom_aliases : (Types.type_expr * Types.type_expr) option)
     type_clash_context =
@@ -200,28 +238,12 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
     fprintf ppf "\n\n  - Did you mean to await this promise before using it?\n"
   | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _})
     when Path.same p1 Predef.path_array ->
-    let src = Ext_io.load_file loc.Location.loc_start.pos_fname in
-    let sub_src = extract_location_string ~src loc in
-    let parsed, comments = !parse_source sub_src in
     let suggested_rewrite =
-      match parsed with
-      | [
-       ({
-          Parsetree.pstr_desc =
-            Pstr_eval (({pexp_desc = Pexp_array items} as exp), l);
-        } as str_item);
-      ] ->
-        Some
-          (!reprint_source
-             [
-               {
-                 str_item with
-                 pstr_desc =
-                   Pstr_eval ({exp with pexp_desc = Pexp_tuple items}, l);
-               };
-             ]
-             comments)
-      | _ -> None
+      Parser.reprint_expr_at_loc loc ~mapper:(fun exp ->
+          match exp.Parsetree.pexp_desc with
+          | Pexp_array items ->
+            Some {exp with Parsetree.pexp_desc = Pexp_tuple items}
+          | _ -> None)
     in
     fprintf ppf
       "\n\n  - Fix this by passing a tuple instead of an array%s@{<info>%s@}\n"