AST: clean up async.

Author: cristianoc

compiler/frontend/ast_attributes.ml

@@ -143,7 +143,6 @@ let is_inline : attr -> bool = fun ({txt}, _) -> txt = "inline"
 let has_inline_payload (attrs : t) = Ext_list.find_first attrs is_inline
 
 let has_await_payload (attrs : t) = Ext_list.find_first attrs Ast_await.is_await
-let has_async_payload (attrs : t) = Ext_list.find_first attrs Ast_async.is_async
 
 type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed]
 

compiler/frontend/ast_attributes.mli

@@ -36,7 +36,6 @@ val process_attributes_rev : t -> attr_kind * t
 val has_inline_payload : t -> attr option
 
 val has_await_payload : t -> attr option
-val has_async_payload : t -> attr option
 
 type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed]
 

compiler/frontend/bs_builtin_ppx.ml

@@ -111,12 +111,12 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
     {e with pexp_desc = Pexp_constant (Pconst_integer (s, None))}
   (* End rewriting *)
   | Pexp_newtype (s, body) ->
-    let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in
+    let async = Ast_async.has_async_payload e.pexp_attributes in
     let body = Ast_async.add_async_attribute ~async body in
     let res = self.expr self body in
     {e with pexp_desc = Pexp_newtype (s, res)}
   | Pexp_fun {arg_label = label; lhs = pat; rhs = body} -> (
-    let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in
+    let async = Ast_async.has_async_payload e.pexp_attributes in
     match Ast_attributes.process_attributes_rev e.pexp_attributes with
     | Nothing, _ ->
       (* Handle @async x => y => ... is in async context *)

compiler/ml/ast_async.ml

@@ -1,5 +1,27 @@
-let is_async : Parsetree.attribute -> bool =
- fun ({txt}, _) -> txt = "async" || txt = "res.async"
+let is_async : Parsetree.attribute -> bool = fun ({txt}, _) -> txt = "res.async"
+
+let has_async_payload attrs = Ext_list.exists attrs is_async
+
+let make_async_attr loc = (Location.mkloc "res.async" loc, Parsetree.PStr [])
+
+let add_async_attribute ~async (body : Parsetree.expression) =
+  if async then
+    {
+      body with
+      pexp_attributes =
+        ({txt = "res.async"; loc = Location.none}, PStr [])
+        :: body.pexp_attributes;
+    }
+  else body
+
+let extract_async_attribute attrs =
+  let rec process async acc attrs =
+    match attrs with
+    | [] -> (async, List.rev acc)
+    | ({Location.txt = "res.async"}, _) :: rest -> process true acc rest
+    | attr :: rest -> process async (attr :: acc) rest
+  in
+  process false [] attrs
 
 let add_promise_type ?(loc = Location.none) ~async
     (result : Parsetree.expression) =
@@ -11,33 +33,6 @@ let add_promise_type ?(loc = Location.none) ~async
     Ast_helper.Exp.apply ~loc unsafe_async [(Nolabel, result)]
   else result
 
-let add_async_attribute ~async (body : Parsetree.expression) =
-  if async then
-    match body.pexp_desc with
-    | Pexp_construct (x, Some e) when Ast_uncurried.expr_is_uncurried_fun body
-      ->
-      {
-        body with
-        pexp_desc =
-          Pexp_construct
-            ( x,
-              Some
-                {
-                  e with
-                  pexp_attributes =
-                    ({txt = "res.async"; loc = Location.none}, PStr [])
-                    :: e.pexp_attributes;
-                } );
-      }
-    | _ ->
-      {
-        body with
-        pexp_attributes =
-          ({txt = "res.async"; loc = Location.none}, PStr [])
-          :: body.pexp_attributes;
-      }
-  else body
-
 let rec add_promise_to_result ~loc (e : Parsetree.expression) =
   match e.pexp_desc with
   | Pexp_fun f ->

compiler/ml/translcore.ml

@@ -652,9 +652,6 @@ let rec cut n l =
 
 let try_ids = Hashtbl.create 8
 
-let has_async_attribute exp =
-  exp.exp_attributes |> List.exists (fun ({txt}, _payload) -> txt = "res.async")
-
 let extract_directive_for_fn exp =
   exp.exp_attributes
   |> List.find_map (fun ({txt}, payload) ->
@@ -675,7 +672,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_let (rec_flag, pat_expr_list, body) ->
     transl_let rec_flag pat_expr_list (transl_exp body)
   | Texp_function {arg_label = _; arity; param; case; partial} -> (
-    let async = has_async_attribute e in
+    let async = Ast_async.has_async_payload e.exp_attributes in
     let directive =
       match extract_directive_for_fn e with
       | None -> None
@@ -1056,7 +1053,8 @@ and transl_function loc partial param case =
            };
      } as exp;
   }
-    when Parmatch.inactive ~partial pat && not (exp |> has_async_attribute) ->
+    when Parmatch.inactive ~partial pat
+         && not (Ast_async.has_async_payload exp.exp_attributes) ->
     let params, body, return_unit =
       transl_function exp.exp_loc partial' param' case
     in

compiler/syntax/src/res_core.ml

@@ -156,7 +156,6 @@ let jsx_attr = (Location.mknoloc "JSX", Parsetree.PStr [])
 let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr [])
 let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr [])
 let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr [])
-let make_async_attr loc = (Location.mkloc "res.async" loc, Parsetree.PStr [])
 let suppress_fragile_match_warning_attr =
   ( Location.mknoloc "warning",
     Parsetree.PStr
@@ -3321,7 +3320,9 @@ and parse_expr_block ?first p =
 and parse_async_arrow_expression ?(arrow_attrs = []) p =
   let start_pos = p.Parser.start_pos in
   Parser.expect (Lident "async") p;
-  let async_attr = make_async_attr (mk_loc start_pos p.prev_end_pos) in
+  let async_attr =
+    Ast_async.make_async_attr (mk_loc start_pos p.prev_end_pos)
+  in
   parse_es6_arrow_expression
     ~arrow_attrs:(async_attr :: arrow_attrs)
     ~arrow_start_pos:(Some start_pos) p

compiler/syntax/src/res_parsetree_viewer.ml

@@ -86,17 +86,6 @@ let has_partial_attribute attrs =
       | _ -> false)
     attrs
 
-type function_attributes_info = {async: bool; attributes: Parsetree.attributes}
-
-let process_function_attributes attrs =
-  let rec process async bs acc attrs =
-    match attrs with
-    | [] -> {async; attributes = List.rev acc}
-    | ({Location.txt = "res.async"}, _) :: rest -> process true bs acc rest
-    | attr :: rest -> process async bs (attr :: acc) rest
-  in
-  process false false [] attrs
-
 let has_await_attribute attrs =
   List.exists
     (function

compiler/syntax/src/res_parsetree_viewer.mli

@@ -19,12 +19,6 @@ val process_partial_app_attribute :
 
 val has_partial_attribute : Parsetree.attributes -> bool
 
-type function_attributes_info = {async: bool; attributes: Parsetree.attributes}
-
-(* determines whether a function is async and/or uncurried based on the given attributes *)
-val process_function_attributes :
-  Parsetree.attributes -> function_attributes_info
-
 val has_await_attribute : Parsetree.attributes -> bool
 val has_res_pat_variant_spread_attribute : Parsetree.attributes -> bool
 val has_dict_pattern_attribute : Parsetree.attributes -> bool

compiler/syntax/src/res_printer.ml

@@ -2694,9 +2694,7 @@ and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl =
 and print_expression ~state (e : Parsetree.expression) cmt_tbl =
   let print_arrow e =
     let attrs_on_arrow, parameters, return_expr = ParsetreeViewer.fun_expr e in
-    let ParsetreeViewer.{async; attributes = attrs} =
-      ParsetreeViewer.process_function_attributes attrs_on_arrow
-    in
+    let async, attrs = Ast_async.extract_async_attribute attrs_on_arrow in
     let return_expr, typ_constraint =
       match return_expr.pexp_desc with
       | Pexp_constraint (expr, typ) ->
@@ -3437,9 +3435,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl =
 
 and print_pexp_fun ~state ~in_callback e cmt_tbl =
   let attrs_on_arrow, parameters, return_expr = ParsetreeViewer.fun_expr e in
-  let ParsetreeViewer.{async; attributes = attrs} =
-    ParsetreeViewer.process_function_attributes attrs_on_arrow
-  in
+  let async, attrs = Ast_async.extract_async_attribute attrs_on_arrow in
   let return_expr, typ_constraint =
     match return_expr.pexp_desc with
     | Pexp_constraint (expr, typ) ->