Move function switch_track_names_of_constructors to bucklescript.

cristianoc · cristianoc · commit 99ae45428418 · 2019-09-11T05:34:07.000+02:00
Sync up ocaml too.
diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml
@@ -93,6 +93,38 @@ type default_case =
 let no_effects_const  = lazy true
 let has_effects_const = lazy false
 
+let names_from_construct_pattern (pat: Typedtree.pattern) =
+  let names_from_type_variant cstrs =
+    let (consts, blocks) = List.fold_left
+      (fun (consts, blocks) cstr ->
+        if cstr.Types.cd_args = []
+        then (Ident.name cstr.Types.cd_id :: consts, blocks)
+        else (consts, Ident.name cstr.Types.cd_id :: blocks))
+      ([], []) cstrs in
+    Some {Lambda.consts = consts |> List.rev |> Array.of_list;
+          blocks = blocks |> List.rev |> Array.of_list } in
+
+  let rec resolve_path n path =
+    match Env.find_type path pat.pat_env with
+    | {type_kind = Type_variant cstrs} ->
+      names_from_type_variant cstrs
+    | {type_kind = Type_abstract; type_manifest = Some t} ->
+      ( match (Ctype.unalias t).desc with
+        | Tconstr (pathn, _, _) ->
+          (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
+          resolve_path (n+1) pathn
+        | _ -> None)
+    | {type_kind = Type_abstract; type_manifest = None} ->
+      None
+    | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
+      None in
+
+  match (Btype.repr pat.pat_type).desc with
+    | Tconstr (path, _, _) -> resolve_path 0 path
+    | _ -> assert false
+
+ let () = Matching.names_from_construct_pattern := names_from_construct_pattern
+
 (** We drop the ability of cross-compiling
         the compiler has to be the same running
 *)
diff --git a/lib/4.02.3/unstable/js_compiler.ml b/lib/4.02.3/unstable/js_compiler.ml
@@ -89497,6 +89497,9 @@ val expand_stringswitch:
 
 val inline_lazy_force : lambda -> Location.t -> lambda
 
+(* To be set by Lam_compile *)
+val names_from_construct_pattern : (pattern -> switch_names option) ref
+
 end = struct
 #1 "matching.ml"
 (***********************************************************************)
@@ -92321,6 +92324,9 @@ let arg_to_var arg cls = match arg with
     let v = name_pattern "match" cls in
     v,Lvar v
 
+(* To be set by Lam_compile *)
+let names_from_construct_pattern : (pattern -> switch_names option) ref =
+  ref (fun _ -> assert false)
 
 (*
   The main compilation function.
@@ -92392,38 +92398,12 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
         (combine_constant names pat.pat_loc arg cst partial)
         ctx pm
   | Tpat_construct (_, cstr, pats) ->
-      let names_from_type_variant cstrs =
-        let (consts, blocks) = List.fold_left
-          (fun (consts, blocks) cstr ->
-            if cstr.Types.cd_args = []
-            then (Ident.name cstr.Types.cd_id :: consts, blocks)
-            else (consts, Ident.name cstr.Types.cd_id :: blocks))
-          ([], []) cstrs in
-        Some {consts = consts |> List.rev |> Array.of_list;
-              blocks = blocks |> List.rev |> Array.of_list } in
-
-      let rec resolve_path n path =
-        match Env.find_type path pat.pat_env with
-        | {type_kind = Type_variant cstrs} ->
-          names_from_type_variant cstrs
-        | {type_kind = Type_abstract; type_manifest = Some t} ->
-          ( match (Ctype.unalias t).desc with
-            | Tconstr (pathn, _, _) ->
-              (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
-              resolve_path (n+1) pathn
-            | _ -> None)
-        | {type_kind = Type_abstract; type_manifest = None} ->
-          None
-        | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
-          None in
-
-      let names = match (Btype.repr pat.pat_type).desc with
-        | Tconstr (path, _, _) -> resolve_path 0 path
-        | _ -> assert false in
-
+      let sw_names = if !Clflags.bs_only
+        then !names_from_construct_pattern pat
+        else None in
       compile_test
         (compile_match repr partial) partial
-        divide_constructor (combine_constructor names pat.pat_loc arg pat cstr partial)
+        divide_constructor (combine_constructor sw_names pat.pat_loc arg pat cstr partial)
         ctx pm
   | Tpat_array _ ->
       let names = None in
@@ -110768,6 +110748,38 @@ type default_case =
 let no_effects_const  = lazy true
 let has_effects_const = lazy false
 
+let names_from_construct_pattern (pat: Typedtree.pattern) =
+  let names_from_type_variant cstrs =
+    let (consts, blocks) = List.fold_left
+      (fun (consts, blocks) cstr ->
+        if cstr.Types.cd_args = []
+        then (Ident.name cstr.Types.cd_id :: consts, blocks)
+        else (consts, Ident.name cstr.Types.cd_id :: blocks))
+      ([], []) cstrs in
+    Some {Lambda.consts = consts |> List.rev |> Array.of_list;
+          blocks = blocks |> List.rev |> Array.of_list } in
+
+  let rec resolve_path n path =
+    match Env.find_type path pat.pat_env with
+    | {type_kind = Type_variant cstrs} ->
+      names_from_type_variant cstrs
+    | {type_kind = Type_abstract; type_manifest = Some t} ->
+      ( match (Ctype.unalias t).desc with
+        | Tconstr (pathn, _, _) ->
+          (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
+          resolve_path (n+1) pathn
+        | _ -> None)
+    | {type_kind = Type_abstract; type_manifest = None} ->
+      None
+    | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
+      None in
+
+  match (Btype.repr pat.pat_type).desc with
+    | Tconstr (path, _, _) -> resolve_path 0 path
+    | _ -> assert false
+
+ let () = Matching.names_from_construct_pattern := names_from_construct_pattern
+
 (** We drop the ability of cross-compiling
         the compiler has to be the same running
 *)
diff --git a/lib/4.02.3/whole_compiler.ml b/lib/4.02.3/whole_compiler.ml
@@ -77017,6 +77017,9 @@ val expand_stringswitch:
 
 val inline_lazy_force : lambda -> Location.t -> lambda
 
+(* To be set by Lam_compile *)
+val names_from_construct_pattern : (pattern -> switch_names option) ref
+
 end = struct
 #1 "matching.ml"
 (***********************************************************************)
@@ -79841,6 +79844,9 @@ let arg_to_var arg cls = match arg with
     let v = name_pattern "match" cls in
     v,Lvar v
 
+(* To be set by Lam_compile *)
+let names_from_construct_pattern : (pattern -> switch_names option) ref =
+  ref (fun _ -> assert false)
 
 (*
   The main compilation function.
@@ -79912,38 +79918,12 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
         (combine_constant names pat.pat_loc arg cst partial)
         ctx pm
   | Tpat_construct (_, cstr, pats) ->
-      let names_from_type_variant cstrs =
-        let (consts, blocks) = List.fold_left
-          (fun (consts, blocks) cstr ->
-            if cstr.Types.cd_args = []
-            then (Ident.name cstr.Types.cd_id :: consts, blocks)
-            else (consts, Ident.name cstr.Types.cd_id :: blocks))
-          ([], []) cstrs in
-        Some {consts = consts |> List.rev |> Array.of_list;
-              blocks = blocks |> List.rev |> Array.of_list } in
-
-      let rec resolve_path n path =
-        match Env.find_type path pat.pat_env with
-        | {type_kind = Type_variant cstrs} ->
-          names_from_type_variant cstrs
-        | {type_kind = Type_abstract; type_manifest = Some t} ->
-          ( match (Ctype.unalias t).desc with
-            | Tconstr (pathn, _, _) ->
-              (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
-              resolve_path (n+1) pathn
-            | _ -> None)
-        | {type_kind = Type_abstract; type_manifest = None} ->
-          None
-        | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
-          None in
-
-      let names = match (Btype.repr pat.pat_type).desc with
-        | Tconstr (path, _, _) -> resolve_path 0 path
-        | _ -> assert false in
-
+      let sw_names = if !Clflags.bs_only
+        then !names_from_construct_pattern pat
+        else None in
       compile_test
         (compile_match repr partial) partial
-        divide_constructor (combine_constructor names pat.pat_loc arg pat cstr partial)
+        divide_constructor (combine_constructor sw_names pat.pat_loc arg pat cstr partial)
         ctx pm
   | Tpat_array _ ->
       let names = None in
@@ -101882,6 +101862,38 @@ type default_case =
 let no_effects_const  = lazy true
 let has_effects_const = lazy false
 
+let names_from_construct_pattern (pat: Typedtree.pattern) =
+  let names_from_type_variant cstrs =
+    let (consts, blocks) = List.fold_left
+      (fun (consts, blocks) cstr ->
+        if cstr.Types.cd_args = []
+        then (Ident.name cstr.Types.cd_id :: consts, blocks)
+        else (consts, Ident.name cstr.Types.cd_id :: blocks))
+      ([], []) cstrs in
+    Some {Lambda.consts = consts |> List.rev |> Array.of_list;
+          blocks = blocks |> List.rev |> Array.of_list } in
+
+  let rec resolve_path n path =
+    match Env.find_type path pat.pat_env with
+    | {type_kind = Type_variant cstrs} ->
+      names_from_type_variant cstrs
+    | {type_kind = Type_abstract; type_manifest = Some t} ->
+      ( match (Ctype.unalias t).desc with
+        | Tconstr (pathn, _, _) ->
+          (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
+          resolve_path (n+1) pathn
+        | _ -> None)
+    | {type_kind = Type_abstract; type_manifest = None} ->
+      None
+    | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
+      None in
+
+  match (Btype.repr pat.pat_type).desc with
+    | Tconstr (path, _, _) -> resolve_path 0 path
+    | _ -> assert false
+
+ let () = Matching.names_from_construct_pattern := names_from_construct_pattern
+
 (** We drop the ability of cross-compiling
         the compiler has to be the same running
 *)
diff --git a/ocaml b/ocaml
@@ -1 +1 @@
-Subproject commit 2c3a6d8becff41167759cd31ebabf1afcec772f7
+Subproject commit 5b63735afead53c61222aadf79fea3016d251638
