PoC of let?

compiler/bsc/rescript_compiler_main.ml

@@ -402,6 +402,10 @@ let command_line_flags : (string * Bsc_args.spec * string) array =
     ( "-absname",
       set absname,
       "*internal* Show absolute filenames in error messages" );
+    ( "-enable-experimental",
+      string_call Experimental_features.enable_from_string,
+      "Enable experimental features: repeatable, e.g. -enable-experimental \
+       LetUnwrap" );
     (* Not used, the build system did the expansion *)
     ( "-bs-no-bin-annot",
       clear Clflags.binary_annotations,

compiler/frontend/ast_attributes.ml

@@ -199,6 +199,12 @@ let has_bs_optional (attrs : t) : bool =
         true
       | _ -> false)
 
+let has_unwrap_attr (attrs : t) : bool =
+  Ext_list.exists attrs (fun ({txt}, _) ->
+      match txt with
+      | "let.unwrap" -> true
+      | _ -> false)
+
 let iter_process_bs_int_as (attrs : t) =
   let st = ref None in
   Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) ->

compiler/frontend/ast_attributes.mli

@@ -46,6 +46,8 @@ val iter_process_bs_string_as : t -> string option
 
 val has_bs_optional : t -> bool
 
+val has_unwrap_attr : t -> bool
+
 val iter_process_bs_int_as : t -> int option
 
 type as_const_payload = Int of int | Str of string * External_arg_spec.delim

compiler/frontend/bs_builtin_ppx.ml

@@ -143,6 +143,124 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
         ] ) ->
     default_expr_mapper self
       {e with pexp_desc = Pexp_ifthenelse (b, t_exp, Some f_exp)}
+    (* Transform:
+     - `@let.unwrap let Ok(inner_pat) = expr`
+     - `@let.unwrap let Error(inner_pat) = expr`
+     - `@let.unwrap let Some(inner_pat) = expr`
+     - `@let.unwrap let None = expr`
+     ...into switches *)
+  | Pexp_let
+      ( Nonrecursive,
+        [
+          {
+            pvb_pat =
+              {
+                ppat_desc =
+                  ( Ppat_construct
+                      ({txt = Lident ("Ok" as variant_name)}, Some _)
+                  | Ppat_construct
+                      ({txt = Lident ("Error" as variant_name)}, Some _)
+                  | Ppat_construct
+                      ({txt = Lident ("Some" as variant_name)}, Some _)
+                  | Ppat_construct
+                      ({txt = Lident ("None" as variant_name)}, None) );
+              } as pvb_pat;
+            pvb_expr;
+            pvb_attributes;
+          };
+        ],
+        body )
+    when Ast_attributes.has_unwrap_attr pvb_attributes -> (
+    if not (Experimental_features.is_enabled Experimental_features.LetUnwrap)
+    then
+      Bs_syntaxerr.err pvb_pat.ppat_loc
+        (Experimental_feature_not_enabled LetUnwrap);
+    let variant : [`Result_Ok | `Result_Error | `Option_Some | `Option_None] =
+      match variant_name with
+      | "Ok" -> `Result_Ok
+      | "Error" -> `Result_Error
+      | "Some" -> `Option_Some
+      | _ -> `Option_None
+    in
+    match pvb_expr.pexp_desc with
+    | Pexp_pack _ -> default_expr_mapper self e
+    | _ ->
+      let cont_case =
+        {
+          Parsetree.pc_bar = None;
+          pc_lhs = pvb_pat;
+          pc_guard = None;
+          pc_rhs = body;
+        }
+      in
+      let loc = {pvb_pat.ppat_loc with loc_ghost = true} in
+      let early_case =
+        match variant with
+        (* Result: continue on Ok(_), early-return on Error(e) *)
+        | `Result_Ok ->
+          {
+            Parsetree.pc_bar = None;
+            pc_lhs =
+              Ast_helper.Pat.alias
+                (Ast_helper.Pat.construct ~loc
+                   {txt = Lident "Error"; loc}
+                   (Some (Ast_helper.Pat.any ~loc ())))
+                {txt = "e"; loc};
+            pc_guard = None;
+            pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident "e"; loc};
+          }
+        (* Result: continue on Error(_), early-return on Ok(x) *)
+        | `Result_Error ->
+          {
+            Parsetree.pc_bar = None;
+            pc_lhs =
+              Ast_helper.Pat.alias
+                (Ast_helper.Pat.construct ~loc {txt = Lident "Ok"; loc}
+                   (Some (Ast_helper.Pat.any ~loc ())))
+                {txt = "x"; loc};
+            pc_guard = None;
+            pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident "x"; loc};
+          }
+        (* Option: continue on Some(_), early-return on None *)
+        | `Option_Some ->
+          {
+            Parsetree.pc_bar = None;
+            pc_lhs =
+              Ast_helper.Pat.alias
+                (Ast_helper.Pat.construct ~loc {txt = Lident "None"; loc} None)
+                {txt = "x"; loc};
+            pc_guard = None;
+            pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident "x"; loc};
+          }
+        (* Option: continue on None, early-return on Some(x) *)
+        | `Option_None ->
+          {
+            Parsetree.pc_bar = None;
+            pc_lhs =
+              Ast_helper.Pat.alias
+                (Ast_helper.Pat.construct ~loc {txt = Lident "Some"; loc}
+                   (Some (Ast_helper.Pat.any ~loc ())))
+                {txt = "x"; loc};
+            pc_guard = None;
+            pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident "x"; loc};
+          }
+      in
+      default_expr_mapper self
+        {
+          e with
+          pexp_desc = Pexp_match (pvb_expr, [early_case; cont_case]);
+          pexp_attributes = e.pexp_attributes @ pvb_attributes;
+        })
+  | Pexp_let (_, [{pvb_pat; pvb_attributes}], _)
+    when Ast_attributes.has_unwrap_attr pvb_attributes ->
+    (* Catch all unsupported cases for `let?` *)
+    if not (Experimental_features.is_enabled Experimental_features.LetUnwrap)
+    then
+      Bs_syntaxerr.err pvb_pat.ppat_loc
+        (Experimental_feature_not_enabled LetUnwrap)
+    else
+      Bs_syntaxerr.err pvb_pat.ppat_loc
+        (LetUnwrap_not_supported_in_position `Unsupported_type)
   | Pexp_let
       ( Nonrecursive,
         [
@@ -333,6 +451,24 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) :
 let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) :
     Parsetree.structure_item =
   match str.pstr_desc with
+  | Pstr_value (_, vbs)
+    when List.exists
+           (fun (vb : Parsetree.value_binding) ->
+             Ast_attributes.has_unwrap_attr vb.pvb_attributes)
+           vbs ->
+    let vb =
+      List.find
+        (fun (vb : Parsetree.value_binding) ->
+          Ast_attributes.has_unwrap_attr vb.pvb_attributes)
+        vbs
+    in
+    if not (Experimental_features.is_enabled Experimental_features.LetUnwrap)
+    then
+      Bs_syntaxerr.err vb.pvb_pat.ppat_loc
+        (Experimental_feature_not_enabled LetUnwrap)
+    else
+      Bs_syntaxerr.err vb.pvb_pat.ppat_loc
+        (LetUnwrap_not_supported_in_position `Toplevel)
   | Pstr_type (rf, tdcls) (* [ {ptype_attributes} as tdcl ] *) ->
     Ast_tdcls.handle_tdcls_in_stru self str rf tdcls
   | Pstr_primitive prim

compiler/frontend/bs_syntaxerr.ml

@@ -47,6 +47,8 @@ type error =
   | Misplaced_label_syntax
   | Optional_in_uncurried_bs_attribute
   | Bs_this_simple_pattern
+  | Experimental_feature_not_enabled of Experimental_features.feature
+  | LetUnwrap_not_supported_in_position of [`Toplevel | `Unsupported_type]
 
 let pp_error fmt err =
   Format.pp_print_string fmt
@@ -82,7 +84,19 @@ let pp_error fmt err =
        each constructor must have an argument."
     | Conflict_ffi_attribute str -> "Conflicting attributes: " ^ str
     | Bs_this_simple_pattern ->
-      "%@this expect its pattern variable to be simple form")
+      "%@this expect its pattern variable to be simple form"
+    | Experimental_feature_not_enabled feature ->
+      Printf.sprintf
+        "Experimental feature not enabled: %s. Enable it by setting \"%s\" to \
+         true under \"experimentalFeatures\" in rescript.json."
+        (Experimental_features.to_string feature)
+        (Experimental_features.to_string feature)
+    | LetUnwrap_not_supported_in_position hint -> (
+      match hint with
+      | `Toplevel -> "`let?` is not allowed for top-level bindings."
+      | `Unsupported_type ->
+        "`let?` is only supported in let bindings targeting the `result` or \
+         `option` type."))
 
 type exn += Error of Location.t * error
 

compiler/frontend/bs_syntaxerr.mli

@@ -47,6 +47,8 @@ type error =
   | Misplaced_label_syntax
   | Optional_in_uncurried_bs_attribute
   | Bs_this_simple_pattern
+  | Experimental_feature_not_enabled of Experimental_features.feature
+  | LetUnwrap_not_supported_in_position of [`Toplevel | `Unsupported_type]
 
 val err : Location.t -> error -> 'a
 

compiler/ml/experimental_features.ml

@@ -0,0 +1,23 @@
+type feature = LetUnwrap
+
+let to_string (f : feature) : string =
+  match f with
+  | LetUnwrap -> "LetUnwrap"
+
+let from_string (s : string) : feature option =
+  match s with
+  | "LetUnwrap" -> Some LetUnwrap
+  | _ -> None
+
+module FeatureSet = Set.Make (struct
+  type t = feature
+  let compare = compare
+end)
+
+let enabled_features : FeatureSet.t ref = ref FeatureSet.empty
+let enable_from_string (s : string) =
+  match from_string s with
+  | Some f -> enabled_features := FeatureSet.add f !enabled_features
+  | None -> ()
+
+let is_enabled (f : feature) = FeatureSet.mem f !enabled_features

compiler/ml/experimental_features.mli

@@ -0,0 +1,5 @@
+type feature = LetUnwrap
+
+val enable_from_string : string -> unit
+val is_enabled : feature -> bool
+val to_string : feature -> string

compiler/syntax/src/res_core.ml

@@ -110,6 +110,12 @@ module ErrorMessages = struct
       ]
     |> Doc.to_string ~width:80
 
+  let experimental_let_unwrap_rec =
+    "let? is not allowed to be recursive. Use a regular `let` or remove `rec`."
+
+  let experimental_let_unwrap_sig =
+    "let? is not allowed in signatures. Use a regular `let` instead."
+
   let type_param =
     "A type param consists of a singlequote followed by a name like `'a` or \
      `'A`"
@@ -2689,21 +2695,35 @@ and parse_attributes_and_binding (p : Parser.t) =
   | _ -> []
 
 (* definition	::=	let [rec] let-binding  { and let-binding }   *)
-and parse_let_bindings ~attrs ~start_pos p =
-  Parser.optional p Let |> ignore;
+and parse_let_bindings ~unwrap ~attrs ~start_pos p =
+  Parser.optional p (Let {unwrap}) |> ignore;
   let rec_flag =
     if Parser.optional p Token.Rec then Asttypes.Recursive
     else Asttypes.Nonrecursive
   in
+  let end_pos = p.Parser.start_pos in
+  if rec_flag = Asttypes.Recursive && unwrap then
+    Parser.err ~start_pos ~end_pos p
+      (Diagnostics.message ErrorMessages.experimental_let_unwrap_rec);
+  let add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs =
+    if unwrap then
+      ( {Asttypes.txt = "let.unwrap"; loc = mk_loc start_pos end_pos},
+        Ast_payload.empty )
+      :: attrs
+    else attrs
+  in
+  let attrs = add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs in
   let first = parse_let_binding_body ~start_pos ~attrs p in
 
   let rec loop p bindings =
     let start_pos = p.Parser.start_pos in
+    let end_pos = p.Parser.end_pos in
     let attrs = parse_attributes_and_binding p in
+    let attrs = add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs in
     match p.Parser.token with
     | And ->
       Parser.next p;
-      ignore (Parser.optional p Let);
+      ignore (Parser.optional p (Let {unwrap = false}));
       (* overparse for fault tolerance *)
       let let_binding = parse_let_binding_body ~start_pos ~attrs p in
       loop p (let_binding :: bindings)
@@ -3437,8 +3457,10 @@ and parse_expr_block_item p =
     let block_expr = parse_expr_block p in
     let loc = mk_loc start_pos p.prev_end_pos in
     Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid block_expr
-  | Let ->
-    let rec_flag, let_bindings = parse_let_bindings ~attrs ~start_pos p in
+  | Let {unwrap} ->
+    let rec_flag, let_bindings =
+      parse_let_bindings ~unwrap ~attrs ~start_pos p
+    in
     parse_newline_or_semicolon_expr_block p;
     let next =
       if Grammar.is_block_expr_start p.Parser.token then parse_expr_block p
@@ -3609,7 +3631,7 @@ and parse_if_or_if_let_expression p =
   Parser.expect If p;
   let expr =
     match p.Parser.token with
-    | Let ->
+    | Let _ ->
       Parser.next p;
       let if_let_expr = parse_if_let_expr start_pos p in
       Parser.err ~start_pos:if_let_expr.pexp_loc.loc_start
@@ -6008,8 +6030,10 @@ and parse_structure_item_region p =
     parse_newline_or_semicolon_structure p;
     let loc = mk_loc start_pos p.prev_end_pos in
     Some (Ast_helper.Str.open_ ~loc open_description)
-  | Let ->
-    let rec_flag, let_bindings = parse_let_bindings ~attrs ~start_pos p in
+  | Let {unwrap} ->
+    let rec_flag, let_bindings =
+      parse_let_bindings ~unwrap ~attrs ~start_pos p
+    in
     parse_newline_or_semicolon_structure p;
     let loc = mk_loc start_pos p.prev_end_pos in
     Some (Ast_helper.Str.value ~loc rec_flag let_bindings)
@@ -6638,7 +6662,11 @@ and parse_signature_item_region p =
   let start_pos = p.Parser.start_pos in
   let attrs = parse_attributes p in
   match p.Parser.token with
-  | Let ->
+  | Let {unwrap} ->
+    if unwrap then (
+      Parser.err ~start_pos ~end_pos:p.Parser.end_pos p
+        (Diagnostics.message ErrorMessages.experimental_let_unwrap_sig);
+      Parser.next p);
     Parser.begin_region p;
     let value_desc = parse_sign_let_desc ~attrs p in
     parse_newline_or_semicolon_signature p;
@@ -6838,7 +6866,7 @@ and parse_module_type_declaration ~attrs ~start_pos p =
 
 and parse_sign_let_desc ~attrs p =
   let start_pos = p.Parser.start_pos in
-  Parser.optional p Let |> ignore;
+  Parser.optional p (Let {unwrap = false}) |> ignore;
   let name, loc = parse_lident p in
   let name = Location.mkloc name loc in
   Parser.expect Colon p;

compiler/syntax/src/res_grammar.ml

@@ -124,8 +124,8 @@ let to_string = function
   | DictRows -> "rows of a dict"
 
 let is_signature_item_start = function
-  | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt
-  | PercentPercent ->
+  | Token.At | Let _ | Typ | External | Exception | Open | Include | Module
+  | AtAt | PercentPercent ->
     true
   | _ -> false
 
@@ -162,7 +162,7 @@ let is_jsx_attribute_start = function
   | _ -> false
 
 let is_structure_item_start = function
-  | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt
+  | Token.Open | Let _ | Typ | External | Exception | Include | Module | AtAt
   | PercentPercent | At ->
     true
   | t when is_expr_start t -> true
@@ -265,7 +265,7 @@ let is_jsx_child_start = is_atomic_expr_start
 let is_block_expr_start = function
   | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | Exception
   | False | Float _ | For | Forwardslash | ForwardslashDot | Hash | If | Int _
-  | Lbrace | Lbracket | LessThan | Let | Lident _ | List | Lparen | Minus
+  | Lbrace | Lbracket | LessThan | Let _ | Lident _ | List | Lparen | Minus
   | MinusDot | Module | Open | Percent | Plus | PlusDot | String _ | Switch
   | True | Try | Uident _ | Underscore | While | Dict ->
     true