Fix location issue for the treatment of async functions

Fixes https://github.com/rescript-lang/rescript-vscode/issues/698

Author: cristianoc

CHANGELOG.md

@@ -28,6 +28,7 @@
 - Fix issue with using alias and default value together https://github.com/rescript-lang/syntax/pull/734
 - Fix issue in `Js.Promise2` where `then` and `catch` were returning `undefined` https://github.com/rescript-lang/rescript-compiler/pull/5996
 - Fix issue in the compiler back-end where async functions passed to an `@uncurry` external would be inlined and transformed in a way that loses async https://github.com/rescript-lang/rescript-compiler/pull/6011
+- Fix location issue for the treatment of `async` functions where hovering on the body with a type error would show `'a => promise<'a>` everywhere
 
 #### :rocket: New Feature
 

jscomp/frontend/ast_async.ml

@@ -1,13 +1,10 @@
-let add_promise_type ~async (result : Parsetree.expression) =
+let add_promise_type ?(loc=Location.none) ~async (result : Parsetree.expression) =
   if async then
-    let txt =
-      Longident.Ldot (Longident.Ldot (Lident "Js", "Promise"), "unsafe_async")
+    let unsafe_async =
+      Ast_helper.Exp.ident ~loc
+        { txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_async"); loc }
     in
-    let pexp_desc = Parsetree.Pexp_ident { txt; loc = result.pexp_loc } in
-    {
-      result with
-      pexp_desc = Pexp_apply ({ result with pexp_desc }, [ (Nolabel, result) ]);
-    }
+    Ast_helper.Exp.apply ~loc unsafe_async [ (Nolabel, result) ]
   else result
 
 let add_async_attribute ~async (body : Parsetree.expression) =
@@ -20,16 +17,16 @@ let add_async_attribute ~async (body : Parsetree.expression) =
     }
   else body
 
-let rec add_promise_to_result (e : Parsetree.expression) =
+let rec add_promise_to_result ~loc (e : Parsetree.expression) =
   match e.pexp_desc with
   | Pexp_fun (label, eo, pat, body) ->
-      let body = add_promise_to_result body in
+      let body = add_promise_to_result ~loc body in
       { e with pexp_desc = Pexp_fun (label, eo, pat, body) }
-  | _ -> add_promise_type ~async:true e
+  | _ -> add_promise_type ~loc ~async:true e
 
 let make_function_async ~async (e : Parsetree.expression) =
   if async then
     match e.pexp_desc with
-    | Pexp_fun _ -> add_async_attribute ~async (add_promise_to_result e)
+    | Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e
     | _ -> assert false
   else e

lib/4.06.1/unstable/js_compiler.ml

@@ -265941,16 +265941,13 @@ end
 module Ast_async
 = struct
 #1 "ast_async.ml"
-let add_promise_type ~async (result : Parsetree.expression) =
+let add_promise_type ?(loc=Location.none) ~async (result : Parsetree.expression) =
   if async then
-    let txt =
-      Longident.Ldot (Longident.Ldot (Lident "Js", "Promise"), "unsafe_async")
+    let unsafe_async =
+      Ast_helper.Exp.ident ~loc
+        { txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_async"); loc }
     in
-    let pexp_desc = Parsetree.Pexp_ident { txt; loc = result.pexp_loc } in
-    {
-      result with
-      pexp_desc = Pexp_apply ({ result with pexp_desc }, [ (Nolabel, result) ]);
-    }
+    Ast_helper.Exp.apply ~loc unsafe_async [ (Nolabel, result) ]
   else result
 
 let add_async_attribute ~async (body : Parsetree.expression) =
@@ -265963,17 +265960,17 @@ let add_async_attribute ~async (body : Parsetree.expression) =
     }
   else body
 
-let rec add_promise_to_result (e : Parsetree.expression) =
+let rec add_promise_to_result ~loc (e : Parsetree.expression) =
   match e.pexp_desc with
   | Pexp_fun (label, eo, pat, body) ->
-      let body = add_promise_to_result body in
+      let body = add_promise_to_result ~loc body in
       { e with pexp_desc = Pexp_fun (label, eo, pat, body) }
-  | _ -> add_promise_type ~async:true e
+  | _ -> add_promise_type ~loc ~async:true e
 
 let make_function_async ~async (e : Parsetree.expression) =
   if async then
     match e.pexp_desc with
-    | Pexp_fun _ -> add_async_attribute ~async (add_promise_to_result e)
+    | Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e
     | _ -> assert false
   else e
 

lib/4.06.1/unstable/js_playground_compiler.ml

@@ -265941,16 +265941,13 @@ end
 module Ast_async
 = struct
 #1 "ast_async.ml"
-let add_promise_type ~async (result : Parsetree.expression) =
+let add_promise_type ?(loc=Location.none) ~async (result : Parsetree.expression) =
   if async then
-    let txt =
-      Longident.Ldot (Longident.Ldot (Lident "Js", "Promise"), "unsafe_async")
+    let unsafe_async =
+      Ast_helper.Exp.ident ~loc
+        { txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_async"); loc }
     in
-    let pexp_desc = Parsetree.Pexp_ident { txt; loc = result.pexp_loc } in
-    {
-      result with
-      pexp_desc = Pexp_apply ({ result with pexp_desc }, [ (Nolabel, result) ]);
-    }
+    Ast_helper.Exp.apply ~loc unsafe_async [ (Nolabel, result) ]
   else result
 
 let add_async_attribute ~async (body : Parsetree.expression) =
@@ -265963,17 +265960,17 @@ let add_async_attribute ~async (body : Parsetree.expression) =
     }
   else body
 
-let rec add_promise_to_result (e : Parsetree.expression) =
+let rec add_promise_to_result ~loc (e : Parsetree.expression) =
   match e.pexp_desc with
   | Pexp_fun (label, eo, pat, body) ->
-      let body = add_promise_to_result body in
+      let body = add_promise_to_result ~loc body in
       { e with pexp_desc = Pexp_fun (label, eo, pat, body) }
-  | _ -> add_promise_type ~async:true e
+  | _ -> add_promise_type ~loc ~async:true e
 
 let make_function_async ~async (e : Parsetree.expression) =
   if async then
     match e.pexp_desc with
-    | Pexp_fun _ -> add_async_attribute ~async (add_promise_to_result e)
+    | Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e
     | _ -> assert false
   else e
 

lib/4.06.1/whole_compiler.ml

@@ -276328,16 +276328,13 @@ end
 module Ast_async
 = struct
 #1 "ast_async.ml"
-let add_promise_type ~async (result : Parsetree.expression) =
+let add_promise_type ?(loc=Location.none) ~async (result : Parsetree.expression) =
   if async then
-    let txt =
-      Longident.Ldot (Longident.Ldot (Lident "Js", "Promise"), "unsafe_async")
+    let unsafe_async =
+      Ast_helper.Exp.ident ~loc
+        { txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_async"); loc }
     in
-    let pexp_desc = Parsetree.Pexp_ident { txt; loc = result.pexp_loc } in
-    {
-      result with
-      pexp_desc = Pexp_apply ({ result with pexp_desc }, [ (Nolabel, result) ]);
-    }
+    Ast_helper.Exp.apply ~loc unsafe_async [ (Nolabel, result) ]
   else result
 
 let add_async_attribute ~async (body : Parsetree.expression) =
@@ -276350,17 +276347,17 @@ let add_async_attribute ~async (body : Parsetree.expression) =
     }
   else body
 
-let rec add_promise_to_result (e : Parsetree.expression) =
+let rec add_promise_to_result ~loc (e : Parsetree.expression) =
   match e.pexp_desc with
   | Pexp_fun (label, eo, pat, body) ->
-      let body = add_promise_to_result body in
+      let body = add_promise_to_result ~loc body in
       { e with pexp_desc = Pexp_fun (label, eo, pat, body) }
-  | _ -> add_promise_type ~async:true e
+  | _ -> add_promise_type ~loc ~async:true e
 
 let make_function_async ~async (e : Parsetree.expression) =
   if async then
     match e.pexp_desc with
-    | Pexp_fun _ -> add_async_attribute ~async (add_promise_to_result e)
+    | Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e
     | _ -> assert false
   else e