Add let.Foo sugar for continuation-passing-style

formatTest/typeCheckedTests/expected_output/sequences.re

@@ -75,3 +75,18 @@ let singlePunAcceptedIfExtended = {
   ...firstFieldPunned,
   a,
 };
+
+let opt = (value, fn) =>
+  switch (value) {
+  | None => None
+  | Some(x) => fn(x)
+  };
+
+let _ = {
+  let!opt x = Some(10);
+
+  let!opt a = Some(2);
+  print_endline(string_of_int(a));
+
+  Some(a + x);
+};

formatTest/typeCheckedTests/input/sequences.re

@@ -79,3 +79,18 @@ let thirdFieldPunned = {
   c
 };
 let singlePunAcceptedIfExtended = {...firstFieldPunned, a};
+
+
+let opt = (value, fn) => switch value {
+  | None => None
+  | Some(x) => fn(x)
+};
+
+let _ = {
+  let!opt x = Some(10);
+
+  let!opt a = Some(2);
+  print_endline(string_of_int(a));
+
+  Some(a + x);
+};

src/reason-parser/jbuild

@@ -56,6 +56,7 @@
     reason_syntax_util
     reason_comment
     reason_layout
+    reason_attrs
     reason_heuristics
     reason_location
     reason_toolchain

src/reason-parser/reason_attrs.ml

@@ -0,0 +1,102 @@
+
+open Ast_404
+open Parsetree
+open Location
+
+module T = struct
+  (** Kinds of attributes *)
+  type attributesPartition = {
+    arityAttrs : attributes;
+    docAttrs : attributes;
+    stdAttrs : attributes;
+    jsxAttrs : attributes;
+    refmtAttrs : attributes;
+    literalAttrs : attributes;
+    uncurried : bool
+  }
+end
+
+let letCPSTag = "let_continuation_passing_style"
+
+let isRefmtTag tag attr =
+  match attr with
+  | (
+      {txt="refmt"; loc},
+      PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_string(foundTag, None))}, _)}]
+    ) -> foundTag = tag
+  | _ -> false
+
+let hasRefmtTag tag = List.exists (isRefmtTag tag)
+
+let isRefmt ~filter attr =
+  match attr with
+  | (
+      {txt="refmt"; loc},
+      PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Pconst_string(tag, None))}, _)}]
+    ) -> (
+      match filter with
+      | None -> true
+      | Some style -> String.compare tag style == 0
+    )
+  | _ -> false
+let isRefmtExplicitBraces = isRefmt ~filter:(Some "explicitBraces")
+let isRefmtInlineOpen = isRefmt ~filter:(Some "inlineOpen")
+
+(** Partition attributes into kinds *)
+let rec partitionAttributes ?(partDoc=false) ?(allowUncurry=true) attrs : T.attributesPartition =
+  let open T in
+  match attrs with
+    | [] ->
+      {arityAttrs=[]; docAttrs=[]; stdAttrs=[]; jsxAttrs=[]; refmtAttrs=[]; literalAttrs=[]; uncurried = false}
+    | (({txt = "bs"}, PStr []) as attr)::atTl ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        if allowUncurry then
+          {partition with uncurried = true}
+        else {partition with stdAttrs=attr::partition.stdAttrs}
+    | attr::atTl when isRefmt ~filter:None attr ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with refmtAttrs=attr::partition.refmtAttrs}
+    | (({txt="JSX"; loc}, _) as jsx)::atTl ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with jsxAttrs=jsx::partition.jsxAttrs}
+    | (({txt="explicit_arity"; loc}, _) as arity_attr)::atTl
+    | (({txt="implicit_arity"; loc}, _) as arity_attr)::atTl ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with arityAttrs=arity_attr::partition.arityAttrs}
+    | (({txt="ocaml.text"; loc}, _) as doc)::atTl when partDoc = true ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with docAttrs=doc::partition.docAttrs}
+    | (({txt="ocaml.doc"; loc}, _) as doc)::atTl when partDoc = true ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with docAttrs=doc::partition.docAttrs}
+    | (({txt="reason.raw_literal"; _}, _) as attr) :: atTl ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with literalAttrs=attr::partition.literalAttrs}
+    | atHd :: atTl ->
+        let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
+        {partition with stdAttrs=atHd::partition.stdAttrs}
+
+let extractStdAttrs attrs =
+  (partitionAttributes attrs).stdAttrs
+
+let extract_raw_literal attrs =
+  let rec loop acc = function
+    | ({txt="reason.raw_literal"; loc},
+       PStr [{pstr_desc = Pstr_eval({pexp_desc = Pexp_constant(Pconst_string(text, None)); _}, _); _}])
+      :: rest ->
+      (Some text, List.rev_append acc rest)
+    | [] -> (None, List.rev acc)
+    | attr :: rest -> loop (attr :: acc) rest
+  in
+  loop [] attrs
+
+(* Returns (selected, remaining) *)
+let rec partition fn attrs : attribute list * attribute list =
+  match attrs with
+  | [] -> ([], [])
+  | attr::atTl when fn attr ->
+    let (selectedRec, remainingRec) = partition fn atTl in
+    (attr::selectedRec, remainingRec)
+  | attr::atTl ->
+    let (selectedRec, remainingRec) = partition fn atTl in
+    (selectedRec, attr::remainingRec)

src/reason-parser/reason_parser.mly

@@ -258,6 +258,15 @@ let simple_ghost_text_attr ?(loc=dummy_loc ()) txt =
   let loc = set_loc_state true loc in
   [({txt; loc}, PStr [])]
 
+(* used for storing stylistic information in the AST *)
+(* As if you had written [@refmt "txt"] *)
+let simple_ghost_refmt_text_attr ?(loc=dummy_loc ()) txt =
+  let loc = set_loc_state true loc in
+  (
+    {txt="refmt"; loc},
+    PStr [{pstr_desc=Pstr_eval(mkexp ~loc (Pexp_constant(Pconst_string(txt, None))), []); pstr_loc=loc}]
+  )
+
 let mkExplicitArityTuplePat ?(loc=dummy_loc ()) pat =
   (* Tell OCaml type system that what this tuple construction represents is
      not actually a tuple, and should represent several constructor
@@ -882,34 +891,61 @@ type let_bindings =
   { lbs_bindings: Parsetree.value_binding list;
     lbs_rec: rec_flag;
     lbs_extension: (attributes * string Asttypes.loc) option;
+    lbs_bang: Longident.t Asttypes.loc option;
     lbs_loc: Location.t }
 
-let mklbs ext rf lb loc =
+let mklbs bang ext rf lb loc =
   { lbs_bindings = [lb];
     lbs_rec = rf;
     lbs_extension = ext;
+    lbs_bang = bang;
     lbs_loc = loc; }
 
 let addlbs lbs lbs' =
   { lbs with lbs_bindings = lbs.lbs_bindings @ lbs' }
 
 let val_of_let_bindings lbs =
   let str = Str.value lbs.lbs_rec lbs.lbs_bindings in
+  if lbs.lbs_bang <> None then
+    raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "let!foo is not allowed at the top level")));
   match lbs.lbs_extension with
   | None -> str
   | Some ext -> struct_item_extension ext [str]
 
+let continuation_passing_style_of_let_bindings attr lbs body =
+    match lbs.lbs_bindings with
+    | [one] ->
+      Exp.apply
+      ~attrs:[simple_ghost_refmt_text_attr Reason_attrs.letCPSTag]
+      ~loc:one.pvb_loc
+      (Exp.ident ~loc:attr.loc attr) [
+        (Nolabel, one.pvb_expr);
+        (Nolabel, Exp.fun_ ~loc:attr.loc Nolabel None one.pvb_pat body)
+      ]
+    | _ ->
+      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "Cannot have `and` in a `let!foo` construct.")))
+
 let expr_of_let_bindings lbs body =
   (* The location of this expression unfortunately includes the entire rule,
    * which will include any preceeding extensions. *)
-  let item_expr = Exp.let_ lbs.lbs_rec lbs.lbs_bindings body in
-  match lbs.lbs_extension with
-  | None -> item_expr
-  | Some ext -> expression_extension ext item_expr
+  match lbs.lbs_bang with
+  | Some attr ->
+    if lbs.lbs_extension <> None then
+      raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "let!foo cannot be combined with let%foo")));
+    continuation_passing_style_of_let_bindings attr lbs body
+  | None ->
+    let item_expr = Exp.let_ lbs.lbs_rec lbs.lbs_bindings body in
+    begin
+    match lbs.lbs_extension with
+    | None -> item_expr
+    | Some ext -> expression_extension ext item_expr
+    end
 
 let class_of_let_bindings lbs body =
   if lbs.lbs_extension <> None then
     raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension")));
+  if lbs.lbs_bang <> None then
+    raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "let!foo is not allowed in class bindings")));
   Cl.let_ lbs.lbs_rec lbs.lbs_bindings body
 
 (*
@@ -3360,10 +3396,10 @@ let_bindings: let_binding and_let_binding* { addlbs $1 $2 };
 
 let_binding:
   (* Form with item extension sugar *)
-  item_attributes LET item_extension_sugar? rec_flag let_binding_body
+  item_attributes LET let_bang? item_extension_sugar? rec_flag let_binding_body
   { let loc = mklocation $symbolstartpos $endpos in
-    let pat, expr = $5 in
-    mklbs $3 $4 (Vb.mk ~loc ~attrs:$1 pat expr) loc }
+    let pat, expr = $6 in
+    mklbs $3 $4 $5 (Vb.mk ~loc ~attrs:$1 pat expr) loc }
 ;
 
 let_binding_body:
@@ -4867,6 +4903,10 @@ item_extension_sugar:
   PERCENT attr_id { ([], $2) }
 ;
 
+let_bang:
+  BANG as_loc(val_longident) { $2 }
+;
+
 extension:
   LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
 ;