Ast async

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
@@ -1732,7 +1731,12 @@ and parse_parameter_list p =
       ~f:parse_parameter ~closing:Rparen p
   in
   Parser.expect Rparen p;
-  parameters
+  let has_term_parameter =
+    Ext_list.exists parameters (function
+      | TermParameter _ -> true
+      | _ -> false)
+  in
+  (has_term_parameter, parameters)
 
 (* parameters ::=
  *   | _
@@ -1743,6 +1747,22 @@ and parse_parameter_list p =
  *)
 and parse_parameters p =
   let start_pos = p.Parser.start_pos in
+  let unit_term_parameter () =
+    let loc = mk_loc start_pos p.Parser.prev_end_pos in
+    let unit_pattern =
+      Ast_helper.Pat.construct ~loc
+        (Location.mkloc (Longident.Lident "()") loc)
+        None
+    in
+    TermParameter
+      {
+        attrs = [];
+        label = Asttypes.Nolabel;
+        expr = None;
+        pat = unit_pattern;
+        pos = start_pos;
+      }
+  in
   match p.Parser.token with
   | Lident ident ->
     Parser.next p;
@@ -1770,56 +1790,12 @@ and parse_parameters p =
           pos = start_pos;
         };
     ]
-  | Lparen -> (
+  | Lparen ->
     Parser.next p;
-    match p.Parser.token with
-    | Rparen ->
-      Parser.next p;
-      let loc = mk_loc start_pos p.Parser.prev_end_pos in
-      let unit_pattern =
-        Ast_helper.Pat.construct ~loc
-          (Location.mkloc (Longident.Lident "()") loc)
-          None
-      in
-      [
-        TermParameter
-          {
-            attrs = [];
-            label = Asttypes.Nolabel;
-            expr = None;
-            pat = unit_pattern;
-            pos = start_pos;
-          };
-      ]
-    | Dot -> (
-      Parser.next p;
-      match p.token with
-      | Rparen ->
-        Parser.next p;
-        let loc = mk_loc start_pos p.Parser.prev_end_pos in
-        let unit_pattern =
-          Ast_helper.Pat.construct ~loc
-            (Location.mkloc (Longident.Lident "()") loc)
-            None
-        in
-        [
-          TermParameter
-            {
-              attrs = [];
-              label = Asttypes.Nolabel;
-              expr = None;
-              pat = unit_pattern;
-              pos = start_pos;
-            };
-        ]
-      | _ -> (
-        match parse_parameter_list p with
-        | TermParameter p :: rest ->
-          TermParameter {p with pos = start_pos} :: rest
-        | TypeParameter p :: rest ->
-          TypeParameter {p with pos = start_pos} :: rest
-        | parameters -> parameters))
-    | _ -> parse_parameter_list p)
+    ignore (Parser.optional p Dot);
+    let has_term_parameter, parameters = parse_parameter_list p in
+    if has_term_parameter then parameters
+    else parameters @ [unit_term_parameter ()]
   | token ->
     Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
     []
@@ -3321,7 +3297,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
@@ -198,7 +187,8 @@ let fun_expr expr =
          };
     } ->
       (attrs_before, List.rev acc, rewrite_underscore_apply expr)
-    | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} ->
+    | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs}
+      when n_fun = 0 ->
       let string_locs, return_expr = collect_new_types [string_loc] rest in
       let param = NewTypes {attrs; locs = string_locs} in
       collect ~n_fun attrs_before (param :: acc) return_expr

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) ->

tests/syntax_tests/data/parsing/grammar/expressions/async.res

@@ -35,3 +35,10 @@ let ex1 = await 3 + await 4
 let ex2 = await 3 ** await 4
 let ex3 = await foo->bar(~arg)
 let ex4 = await foo.bar.baz
+
+
+let attr1 = @a async x => x+1
+let attr2 =  @a async (type a) => (type b c, x) => 3
+let attr3 =  @a  (type a) => async (type b c, x) => 3
+let attr4 =  @a  (type a) => @b async (type b c, x) => 3
+let attr5 : int =  @a @b async (type a, type b c) => (x:a) => x

tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt

@@ -44,9 +44,9 @@ let t0 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
 let t1 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
 let t2 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
 let t3 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
-let t4 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
-let t5 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
-let t6 (type a) (type b) [arity:2](l : a list) (x : a) = x :: l
+let t4 (type a) (type b) [arity:1]() [arity:2](l : a list) (x : a) = x :: l
+let t5 (type a) (type b) [arity:1]() [arity:2](l : a list) (x : a) = x :: l
+let t6 (type a) (type b) [arity:1]() [arity:2](l : a list) (x : a) = x :: l
 type nonrec arrowPath1 = int -> string (a:1)
 type nonrec arrowPath2 = I.t -> string (a:1)
 type nonrec arrowPath3 = int -> string (a:1)

tests/syntax_tests/data/parsing/grammar/expressions/expected/async.res.txt

@@ -31,4 +31,18 @@ let bar = ((fun [arity:1]~a:((a)[@res.namedArgLoc ]) -> a + 1)[@res.async ])
 let ex1 = ((3)[@res.await ]) + ((4)[@res.await ])
 let ex2 = ((3)[@res.await ]) ** ((4)[@res.await ])
 let ex3 = ((foo |.u (bar ~arg:((arg)[@res.namedArgLoc ])))[@res.await ])
-let ex4 = (((foo.bar).baz)[@res.await ])
+let ex4 = (((foo.bar).baz)[@res.await ])
+let attr1 = ((fun [arity:1]x -> x + 1)[@res.async ][@a ])
+let attr2 = ((fun (type a) ->
+  fun [arity:1]() -> fun (type b) -> fun (type c) -> fun [arity:1]x -> 3)
+  [@res.async ][@a ])
+let attr3 = ((fun (type a) ->
+  fun [arity:1]() -> ((fun (type b) -> fun (type c) -> fun [arity:1]x -> 3)
+    [@res.async ]))
+  [@a ])
+let attr4 = ((fun (type a) ->
+  fun [arity:1]() -> ((fun (type b) -> fun (type c) -> fun [arity:1]x -> 3)
+    [@res.async ][@b ]))
+  [@a ])
+let (attr5 : int) = ((fun (type a) -> fun (type b) -> fun (type c) ->
+  fun [arity:1]() -> fun [arity:1](x : a) -> x)[@res.async ][@a ][@b ])

tests/syntax_tests/data/printer/comments/expected/expr.res.txt

@@ -227,12 +227,8 @@ let f = (
 ) => /* c7 */ ()
 
 let multiply = (type /* c-2 */ t /* c-1 */, /* c0 */ m1 /* c1 */, /* c2 */ m2 /* c3 */) => ()
-let multiply = (
-  type /* c-4 */ t /* c-3 */,
-  /* c0 */ m1 /* c1 */,
-  type /* c-2 */ s /* c-1 */,
-  /* c2 */ m2 /* c3 */,
-) => ()
+let multiply = (type /* c-4 */ t /* c-3 */, /* c0 */ m1 /* c1 */) =>
+  (type /* c-2 */ s /* c-1 */, /* c2 */ m2 /* c3 */) => ()
 
 f(
   // a

tests/syntax_tests/data/printer/expr/asyncAwait.res

@@ -122,3 +122,9 @@ type t2 = (. int, string) => bool
 let f = async (type a, ()) => {
   await Js.Promise.resolve(())
 }
+
+let attr1 = @a async x => x+1
+let attr2 =  @a async (type a) => (type b c, x) => 3
+let attr3 =  @a  (type a) => async (type b c, x) => 3
+let attr4 =  @a  (type a) => @b async (type b c, x) => 3
+let attr5 : int => promise<int> =  @a @b async (type a, type b c) => (x:a) => x

tests/syntax_tests/data/printer/expr/expected/UncurriedByDefault.res.txt

@@ -53,9 +53,9 @@ let t0 = (type a b, l: list<a>, x: a) => list{x, ...l}
 let t1 = (type a b, l: list<a>, x: a) => list{x, ...l}
 let t2 = (type a b, l: list<a>, x: a) => list{x, ...l}
 let t3 = (type a b, l: list<a>, x: a) => list{x, ...l}
-let t4 = (type a b, l: list<a>, x: a) => list{x, ...l}
-let t5 = (type a b, l: list<a>, x: a) => list{x, ...l}
-let t6 = (type a b, l: list<a>, x: a) => list{x, ...l}
+let t4 = (type a b, ()) => (l: list<a>, x: a) => list{x, ...l}
+let t5 = (type a b, ()) => (l: list<a>, x: a) => list{x, ...l}
+let t6 = (type a b, ()) => (l: list<a>, x: a) => list{x, ...l}
 
 let () = (x => ignore(x))(3)
 let () = (x => ignore(x))(3)

tests/syntax_tests/data/printer/expr/expected/asyncAwait.res.txt

@@ -144,3 +144,9 @@ type t2 = (int, string) => bool
 let f = async (type a, ()) => {
   await Js.Promise.resolve()
 }
+
+let attr1 = @a async x => x + 1
+let attr2 = @a async (type a, ()) => (type b c, x) => 3
+let attr3 = @a (type a, ()) => async (type b c, x) => 3
+let attr4 = @a (type a, ()) => @b async (type b c, x) => 3
+let attr5: int => promise<int> = @a @b async (type a b c, ()) => (x: a) => x