support null variants @mel.as in mixed @mel.unwrap

jscomp/core/lam_compile_external_call.ml

@@ -101,59 +101,75 @@ let append_list x xs =
          }()) === undefined
     ]}
 
-     This would not work with [NonNullString]
-*)
-let rec ocaml_to_js_eff ~(arg_label : External_arg_spec.Arg_label.t)
-    ~(arg_type : External_arg_spec.t) (raw_arg : E.t) :
-    arg_expression * E.t list =
-  let arg =
-    match arg_label with
-    | Arg_optional ->
-        Js_of_lam_option.get_default_undefined_from_optional raw_arg
-    | Arg_label | Arg_empty -> raw_arg
+     This would not work with [NonNullString] *)
+let rec ocaml_to_js_eff =
+  let dispatch_has_field
+      (dispatches : (string * Melange_ffi.External_arg_spec.Arg_cst.t) list)
+      (fields : J.expression list) =
+    match fields with
+    | { expression_desc = Str s; _ } :: _ ->
+        List.exists dispatches ~f:(fun (dispatch, _) -> dispatch = s)
+    | _ -> false
   in
-  match arg_type with
-  | Arg_cst _ -> assert false
-  | Fn_uncurry_arity _ -> assert false
-  (* has to be preprocessed by {!Lam} module first *)
-  | Extern_unit ->
-      ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit),
-        if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] )
-      (* leave up later to decide *)
-  | Ignore ->
-      ( Splice0,
-        if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] )
-  | Poly_var { descr; spread } | Int { descr; spread } ->
-      ( (if spread then Js_of_lam_variant.eval_descr arg descr
-         else Splice1 (Js_of_lam_variant.eval arg descr)),
-        [] )
-  | Unwrap polyvar -> (
-      match (polyvar, raw_arg.expression_desc) with
-      | (Poly_var { descr = _; spread = false } | Int _), Caml_block _ ->
-          Location.raise_errorf ?loc:raw_arg.loc
-            "`[@mel.as ..]' can only be used with `[@mel.unwrap]' variants \
-             without a payload."
-      | (Poly_var { spread = false; _ } | Int _), _ ->
-          ocaml_to_js_eff ~arg_label ~arg_type:polyvar raw_arg
-      | Nothing, _ ->
-          let single_arg =
-            match arg_label with
-            | Arg_optional ->
-                (*
-           If this is an optional arg (like `?arg`), we have to potentially do
-           2 levels of unwrapping:
-           - if ocaml arg is `None`, let js arg be `undefined` (no unwrapping)
-           - if ocaml arg is `Some x`, unwrap the arg to get the `x`, then
-             unwrap the `x` itself
-           - Here `Some x` is `x` due to the current encoding
-           Lets inline here since it depends on the runtime encoding
-        *)
-                Js_of_lam_option.option_unwrap raw_arg
-            | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg
-          in
-          (Splice1 single_arg, [])
-      | _, _ -> assert false)
-  | Nothing -> (Splice1 arg, [])
+  let splice1_single_arg ~arg_label raw_arg =
+    let single_arg =
+      match arg_label with
+      | External_arg_spec.Arg_label.Arg_optional ->
+          (* If this is an optional arg (like `?arg`), we have to potentially
+             do 2 levels of unwrapping:
+               - if ocaml arg is `None`, let js arg be `undefined` (no
+                 unwrapping)
+               - if ocaml arg is `Some x`, unwrap the arg to get the `x`, then
+                 unwrap the `x` itself 
+                 - Here `Some x` is `x` due to the current encoding Lets inline
+                   here since it depends on the runtime encoding *)
+          Js_of_lam_option.option_unwrap raw_arg
+      | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg
+    in
+    (Splice1 single_arg, [])
+  in
+  fun ~arg_label ~arg_type raw_arg ->
+    let arg =
+      match arg_label with
+      | External_arg_spec.Arg_label.Arg_optional ->
+          Js_of_lam_option.get_default_undefined_from_optional raw_arg
+      | Arg_label | Arg_empty -> raw_arg
+    in
+    match arg_type with
+    | External_arg_spec.Arg_cst _ | Fn_uncurry_arity _ -> assert false
+    (* has to be preprocessed by {!Lam} module first *)
+    | Extern_unit ->
+        let splice =
+          match arg_label with
+          | Arg_empty -> Splice0
+          | Arg_optional | Arg_label -> Splice1 E.unit
+        in
+        ( splice,
+          if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] )
+        (* leave up later to decide *)
+    | Ignore ->
+        ( Splice0,
+          if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] )
+    | Poly_var { descr; spread } | Int { descr; spread } ->
+        ( (if spread then Js_of_lam_variant.eval_descr arg descr
+           else Splice1 (Js_of_lam_variant.eval arg descr)),
+          [] )
+    | Unwrap polyvar -> (
+        match (polyvar, raw_arg.expression_desc) with
+        | Poly_var { descr; spread = false }, Caml_block { fields; _ } ->
+            if dispatch_has_field descr fields then
+              Location.raise_errorf ?loc:raw_arg.loc
+                "`[@mel.as ..]' can only be used with `[@mel.unwrap]' variants \
+                 without a payload."
+            else splice1_single_arg ~arg_label raw_arg
+        | Int _, _ ->
+            (* We don't support `@mel.int` with `@mel.unwrap` *)
+            assert false
+        | Poly_var { spread = false; _ }, _ ->
+            ocaml_to_js_eff ~arg_label ~arg_type:polyvar raw_arg
+        | Nothing, _ -> splice1_single_arg ~arg_label raw_arg
+        | _, _ -> assert false)
+    | Nothing -> (Splice1 arg, [])
 
 let empty_pair = ([], [])
 let add_eff eff e = match eff with None -> e | Some v -> E.seq v e
@@ -304,9 +320,12 @@ let translate_ffi =
           ~info:{ arity = Full; call_info = Call_na }
           (E.dot self name) args
   in
-  fun (cxt : Lam_compile_context.t) arg_types
-      (ffi : External_ffi_types.external_spec) (args : J.expression list)
-      ~dynamic_import ->
+  fun (cxt : Lam_compile_context.t)
+    arg_types
+    (ffi : External_ffi_types.external_spec)
+    (args : J.expression list)
+    ~dynamic_import
+  ->
     match ffi with
     | Js_call
         { external_module_name = module_name; name = fn; variadic; scopes } -> (

ppx/ast_polyvar.ml

@@ -49,14 +49,15 @@ let map_row_fields_into_ints =
     let case, _, result =
       List.fold_left row_fields ~init:(`Nothing, 0, [])
         ~f:(fun (nullary, i, acc) { prf_desc; prf_attributes; _ } ->
-          match (nullary, prf_desc) with
-          | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) ->
-              let i = process_mel_as ~attrs:prf_attributes i in
-              (`Null, i + 1, (txt, External_arg_spec.Arg_cst.Int i) :: acc)
-          | (`Nothing | `NonNull), Rtag ({ txt; _ }, false, [ _ ]) ->
-              let i = process_mel_as ~attrs:prf_attributes i in
-              (`NonNull, i + 1, (txt, External_arg_spec.Arg_cst.Int i) :: acc)
-          | _ -> Error.err ~loc Invalid_mel_int_type)
+          let nullary, txt =
+            match (nullary, prf_desc) with
+            | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) -> (`Null, txt)
+            | (`Nothing | `NonNull), Rtag ({ txt; _ }, false, [ _ ]) ->
+                (`NonNull, txt)
+            | _ -> Error.err ~loc Invalid_mel_int_type
+          in
+          let i = process_mel_as ~attrs:prf_attributes i in
+          (nullary, i + 1, (txt, External_arg_spec.Arg_cst.Int i) :: acc))
     in
     match case with
     | `Nothing -> assert false
@@ -81,12 +82,14 @@ let map_row_fields_into_strings =
     let case, result =
       List.fold_right
         ~f:(fun tag (nullary, acc) ->
-          match (nullary, tag.prf_desc) with
-          | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) ->
-              (`Null, process_mel_as tag ~txt ~has_mel_as :: acc)
-          | (`Nothing | `NonNull), Rtag ({ txt; _ }, false, [ _ ]) ->
-              (`NonNull, process_mel_as tag ~txt ~has_mel_as :: acc)
-          | _ -> Error.err ~loc Invalid_mel_string_type)
+          let nullary, txt =
+            match (nullary, tag.prf_desc) with
+            | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) -> (`Null, txt)
+            | (`Nothing | `NonNull), Rtag ({ txt; _ }, false, [ _ ]) ->
+                (`NonNull, txt)
+            | _ -> Error.err ~loc Invalid_mel_string_type
+          in
+          (nullary, process_mel_as tag ~txt ~has_mel_as :: acc))
         row_fields ~init:(`Nothing, [])
     in
     match (case, !has_mel_as) with
@@ -114,15 +117,14 @@ let map_row_fields_into_spread (row_fields : row_field list) ~loc =
 let infer_mel_as ~loc row_fields =
   let has_mel_as = ref false in
   let result =
-    List.map row_fields ~f:(fun { prf_desc; prf_attributes; _ } ->
+    List.filter_map row_fields ~f:(fun { prf_desc; prf_attributes; _ } ->
         match prf_desc with
-        | Rtag ({ txt; _ }, _, _) ->
-            ( txt,
-              match Ast_attributes.iter_process_mel_as_cst prf_attributes with
-              | Some x ->
-                  has_mel_as := true;
-                  x
-              | None -> Str txt )
+        | Rtag ({ txt; _ }, _, _) -> (
+            match Ast_attributes.iter_process_mel_as_cst prf_attributes with
+            | Some x ->
+                has_mel_as := true;
+                Some (txt, x)
+            | None -> None)
         | _ -> Error.err ~loc Invalid_mel_spread_type)
   in
   if !has_mel_as then

test/blackbox-tests/mel-unwrap-no-payload.t

@@ -80,3 +80,17 @@ Test `@mel.unwrap` + polyvariants with no payload
   ]);
   /*  Not a pure module */
 
+  $ cat > x.ml <<EOF
+  > external foo : ([ \`foo [@mel.as "x"] | \`int of int ][@mel.unwrap]) -> unit = "someFnCall"
+  > let () = foo \`foo; foo (\`int 42)
+  > EOF
+  $ melc -ppx melppx x.ml
+  // Generated by Melange
+  'use strict';
+
+
+  someFnCall("x");
+
+  someFnCall(42);
+  /*  Not a pure module */
+