From c16823e37cb90d0c9fa7aa2d32f8d306093ad3fd Mon Sep 17 00:00:00 2001
From: Cristiano Calcagno <cristianoc@users.noreply.github.com>
Date: Sun, 19 Feb 2023 15:10:58 +0100
Subject: [PATCH] Fix location issue for the treatment of `async` functions

Fixes https://github.com/rescript-lang/rescript-vscode/issues/698
---
 CHANGELOG.md                                  |  1 +
 jscomp/frontend/ast_async.ml                  | 21 ++++++++-----------
 lib/4.06.1/unstable/js_compiler.ml            | 21 ++++++++-----------
 lib/4.06.1/unstable/js_playground_compiler.ml | 21 ++++++++-----------
 lib/4.06.1/whole_compiler.ml                  | 21 ++++++++-----------
 5 files changed, 37 insertions(+), 48 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 28e1b4a987..52f02bc634 100644
--- a/CHANGELOG.md
+++ b/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 https://github.com/rescript-lang/rescript-compiler/pull/6014
 
 #### :rocket: New Feature
 
diff --git a/jscomp/frontend/ast_async.ml b/jscomp/frontend/ast_async.ml
index aa2f0b3a91..0d3a0d8d9c 100644
--- a/jscomp/frontend/ast_async.ml
+++ b/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
diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml
index a0b1123752..a50f889e77 100644
--- a/lib/4.06.1/unstable/js_compiler.ml
+++ b/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
 
diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml
index bcc024fd71..f48ba0a1d6 100644
--- a/lib/4.06.1/unstable/js_playground_compiler.ml
+++ b/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
 
diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml
index e3864ac9ff..ad82c713e5 100644
--- a/lib/4.06.1/whole_compiler.ml
+++ b/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