PoC of let?

CHANGELOG.md

@@ -21,6 +21,8 @@
 #### :rocket: New Feature
 
 - Add support for ArrayBuffer and typed arrays to `@unboxed`. https://github.com/rescript-lang/rescript/pull/7788
+- Experimental: Add `let?` syntax for unwrapping and propagating errors/none as early returns for option/result types. https://github.com/rescript-lang/rescript/pull/7582
+- Add support for shipping features as experimental, including configuring what experimental features are enabled in `rescript.json`. https://github.com/rescript-lang/rescript/pull/7582
 
 #### :bug: Bug fix
 

compiler/bsc/rescript_compiler_main.ml

@@ -393,6 +393,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/error_message_utils.ml

@@ -96,6 +96,7 @@ type type_clash_context =
   | IfReturn
   | TernaryReturn
   | SwitchReturn
+  | LetUnwrapReturn
   | TryReturn
   | StringConcat
   | ComparisonOperator
@@ -131,6 +132,7 @@ let context_to_string = function
   | Some TernaryReturn -> "TernaryReturn"
   | Some Await -> "Await"
   | Some BracedIdent -> "BracedIdent"
+  | Some LetUnwrapReturn -> "LetUnwrapReturn"
   | None -> "None"
 
 let fprintf = Format.fprintf
@@ -163,6 +165,8 @@ let error_expected_type_text ppf type_clash_context =
   | Some ComparisonOperator ->
     fprintf ppf "But it's being compared to something of type:"
   | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:"
+  | Some LetUnwrapReturn ->
+    fprintf ppf "But this @{<info>let?@} is used where this type is expected:"
   | Some TryReturn -> fprintf ppf "But this try/catch is expected to return:"
   | Some WhileCondition ->
     fprintf ppf "But a @{<info>while@} loop condition must always be of type:"
@@ -314,6 +318,65 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
       "\n\n\
       \  All branches in a @{<info>switch@} must return the same type.@,\
        To fix this, change your branch to return the expected type."
+  | Some LetUnwrapReturn, bottom_aliases -> (
+    let kind =
+      match bottom_aliases with
+      | Some ({Types.desc = Tconstr (p, _, _)}, _)
+        when Path.same p Predef.path_option ->
+        `Option
+      | Some (_, {Types.desc = Tconstr (p, _, _)})
+        when Path.same p Predef.path_option ->
+        `Option
+      | Some ({Types.desc = Tconstr (p, _, _)}, _)
+        when Path.same p Predef.path_result ->
+        `Result
+      | Some (_, {Types.desc = Tconstr (p, _, _)})
+        when Path.same p Predef.path_result ->
+        `Result
+      | _ -> `Unknown
+    in
+    match kind with
+    | `Option ->
+      fprintf ppf
+        "\n\n\
+        \  This @{<info>let?@} unwraps an @{<info>option@}; use it where the \
+         enclosing function or let binding returns an @{<info>option@} so \
+         @{<info>None@} can propagate.\n\n\
+        \  Possible solutions:\n\
+        \  - Change the enclosing function or let binding to return \
+         @{<info>option<'t>@} and use @{<info>Some@} for success; \
+         @{<info>let?@} will propagate @{<info>None@}.\n\
+        \  - Replace @{<info>let?@} with a @{<info>switch@} and handle the \
+         @{<info>None@} case explicitly.\n\
+        \  - If you want a default value instead of early return, unwrap using \
+         @{<info>Option.getOr(default)@}."
+    | `Result ->
+      fprintf ppf
+        "\n\n\
+        \  This @{<info>let?@} unwraps a @{<info>result@}; use it where the \
+         enclosing function or let binding returns a @{<info>result@} so \
+         @{<info>Error@} can propagate.\n\n\
+        \  Possible solutions:\n\
+        \  - Change the enclosing function or let binding to return \
+         @{<info>result<'ok, 'error>@}; use @{<info>Ok@} for success, and \
+         @{<info>let?@} will propagate @{<info>Error@}.\n\
+        \  - Replace @{<info>let?@} with a @{<info>switch@} and handle the \
+         @{<info>Error@} case explicitly.\n\
+        \  - If you want a default value instead of early return, unwrap using \
+         @{<info>Result.getOr(default)@}."
+    | `Unknown ->
+      fprintf ppf
+        "\n\n\
+        \  @{<info>let?@} can only be used in a context that expects \
+         @{<info>option@} or @{<info>result@}.\n\n\
+        \  Possible solutions:\n\
+        \  - Change the enclosing function or let binding to return an \
+         @{<info>option<'t>@} or @{<info>result<'ok, 'error>@} and propagate \
+         with @{<info>Some/Ok@}.\n\
+        \  - Replace @{<info>let?@} with a @{<info>switch@} and handle the \
+         @{<info>None/Error@} case explicitly.\n\
+        \  - If you want a default value instead of early return, unwrap using \
+         @{<info>Option.getOr(default)@} or @{<info>Result.getOr(default)@}.")
   | Some TryReturn, _ ->
     fprintf ppf
       "\n\n\

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/ml/parmatch.ml

@@ -2013,7 +2013,7 @@ let ppat_of_type env ty =
     (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0)
   | pats -> Conv.conv (orify_many pats)
 
-let do_check_partial ?pred exhaust loc casel pss =
+let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss =
   match pss with
   | [] ->
     (*
@@ -2071,6 +2071,11 @@ let do_check_partial ?pred exhaust loc casel pss =
                     Matching over values of extensible variant types (the \
                     *extension* above)\n\
                     must include a wild card pattern in order to be exhaustive.";
+               (match partial_match_warning_hint with
+               | None -> ()
+               | Some h when String.length h > 0 ->
+                 Buffer.add_string buf ("\n\n  " ^ h)
+               | Some _ -> ());
                Buffer.contents buf
              with _ -> ""
            in
@@ -2083,8 +2088,8 @@ let do_check_partial_normal loc casel pss =
   do_check_partial exhaust loc casel pss
  *)
 
-let do_check_partial_gadt pred loc casel pss =
-  do_check_partial ~pred exhaust_gadt loc casel pss
+let do_check_partial_gadt ?partial_match_warning_hint pred loc casel pss =
+  do_check_partial ?partial_match_warning_hint ~pred exhaust_gadt loc casel pss
 
 (*****************)
 (* Fragile check *)
@@ -2265,9 +2270,9 @@ let check_partial_param do_check_partial do_check_fragile loc casel =
       do_check_partial_normal
       do_check_fragile_normal*)
 
-let check_partial_gadt pred loc casel =
+let check_partial_gadt ?partial_match_warning_hint pred loc casel =
   check_partial_param
-    (do_check_partial_gadt pred)
+    (do_check_partial_gadt ?partial_match_warning_hint pred)
     do_check_fragile_gadt loc casel
 
 (*************************************)