Work around issue with fresh names from pattern matching.

A pattern is type checked twice. The second time for the exhaustive check coming from the pattern matcher. The second time constructors, such as optionals, have been replaced by fresh symbols starting with `#$`. Now recognize these symbols and do not apply the transformation which adds Some.

Author: cristianoc

jscomp/ml/typecore.ml

@@ -1157,7 +1157,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
  let exp_optional_attr =
  Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
  in
- if label_is_optional ld && not exp_optional_attr then
+ let isFromPamatch = match pat.ppat_desc with
+ | Ppat_construct ({txt = Lident s}, _) ->
+ String.length s >= 2 && s.[0] = '#' && s.[1] = '$'
+ | _ -> false
+ in
+ if label_is_optional ld && not exp_optional_attr && not isFromPamatch then
  let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in
  Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat)
  else pat

jscomp/test/res_debug.js

@@ -16,7 +16,19 @@ var newrecord = Caml_obj.obj_dup(v0);
 newrecord.x = 3;
 
 function testMatch(v) {
- return v.y;
+ var y = v.y;
+ if (y !== undefined) {
+ return y;
+ }
+ throw {
+ RE_EXN_ID: "Match_failure",
+ _1: [
+ "res_debug.res",
+ 50,
+ 2
+ ],
+ Error: new Error()
+ };
 }
 
 var v2 = newrecord;

jscomp/test/res_debug.res

@@ -44,7 +44,7 @@ let v1 : r = { x : 3
  , z : 3
 }
 
-//@@warning("-56") // Turn off match case unreachable
+@@warning("-8") // Turn off incomplete pattern match
 
 let testMatch = v =>
  switch v {

lib/4.06.1/unstable/js_compiler.ml

@@ -40060,7 +40060,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
  let exp_optional_attr =
  Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
  in
- if label_is_optional ld && not exp_optional_attr then
+ let isFromPamatch = match pat.ppat_desc with
+ | Ppat_construct ({txt = Lident s}, _) ->
+ String.length s >= 2 && s.[0] = '#' && s.[1] = '$'
+ | _ -> false
+ in
+ if label_is_optional ld && not exp_optional_attr && not isFromPamatch then
  let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in
  Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat)
  else pat

lib/4.06.1/unstable/js_playground_compiler.ml

@@ -40060,7 +40060,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
  let exp_optional_attr =
  Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
  in
- if label_is_optional ld && not exp_optional_attr then
+ let isFromPamatch = match pat.ppat_desc with
+ | Ppat_construct ({txt = Lident s}, _) ->
+ String.length s >= 2 && s.[0] = '#' && s.[1] = '$'
+ | _ -> false
+ in
+ if label_is_optional ld && not exp_optional_attr && not isFromPamatch then
  let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in
  Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat)
  else pat

lib/4.06.1/whole_compiler.ml

@@ -214591,7 +214591,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
  let exp_optional_attr =
  Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional")
  in
- if label_is_optional ld && not exp_optional_attr then
+ let isFromPamatch = match pat.ppat_desc with
+ | Ppat_construct ({txt = Lident s}, _) ->
+ String.length s >= 2 && s.[0] = '#' && s.[1] = '$'
+ | _ -> false
+ in
+ if label_is_optional ld && not exp_optional_attr && not isFromPamatch then
  let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in
  Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat)
  else pat