[Super errors] add needed patch for better unification errors (#1919)

* [Super errors] add needed patch for better unification errors

* New super_type_expansion function

* Fix patch typo

Author: chenglou

vendor/ocaml/bytecomp/translcore.ml

@@ -617,7 +617,7 @@ let primitive_is_ccall = function
 let assert_failed exp =
   let (fname, line, char) =
     Location.get_pos_info exp.exp_loc.Location.loc_start in
-#if undefined BS_NO_COMPILER_PATH then     
+#if undefined BS_NO_COMPILER_PATCH then     
   let fname = 
     if  not !Location.absname then Filename.basename fname else fname 
   in   

vendor/ocaml/typing/printtyp.ml

@@ -1429,6 +1429,7 @@ let rec trace_same_names = function
       type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem
   | _ -> ()
 
+#if defined BS_NO_COMPILER_PATCH then
 let unification_error unif tr txt1 ppf txt2 =
   reset ();
   trace_same_names tr;
@@ -1457,6 +1458,87 @@ let unification_error unif tr txt1 ppf txt2 =
     with exn ->
       print_labels := true;
       raise exn
+#else
+let super_type_expansion ~tag t ppf t' =
+  if same_path t t' then begin
+    Format.pp_open_tag ppf tag;
+    type_expr ppf t;
+    Format.pp_close_tag ppf ();
+  end else begin
+    let t' = if proxy t == proxy t' then unalias t' else t' in
+    fprintf ppf "@[<2>";
+    Format.pp_open_tag ppf tag;
+    fprintf ppf "%a" type_expr t;
+    Format.pp_close_tag ppf ();
+    fprintf ppf "@ @{<dim>(defined as@}@ ";
+    Format.pp_open_tag ppf tag;
+    fprintf ppf "%a" type_expr t';
+    Format.pp_close_tag ppf ();
+    fprintf ppf "@{<dim>)@}";
+    fprintf ppf "@]";
+  end
+
+let super_trace ppf =
+  let rec super_trace first_report ppf = function
+    | (t1, t1') :: (t2, t2') :: rem ->
+      fprintf ppf 
+        "@,@,@[<v 2>";
+      if first_report then 
+        fprintf ppf "The incompatible parts:@,"
+      else begin 
+        fprintf ppf "Further expanded:@,"
+      end;
+      fprintf ppf 
+        "@[<v>\
+          @[%a@]@,\
+          vs@,\
+          @[%a@]\
+          %a\
+        @]"
+        (super_type_expansion ~tag:"error" t1) t1'
+        (super_type_expansion ~tag:"info" t2) t2'
+        (super_trace false) rem;
+      fprintf ppf "@]"
+    | _ -> ()
+  in super_trace true ppf
+
+let unification_error unif tr txt1 ppf txt2 = begin
+  reset ();
+  trace_same_names tr;
+  let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
+  let mis = mismatch unif tr in
+  match tr with
+  | [] | _ :: [] -> assert false
+  | t1 :: t2 :: tr ->
+    try
+      let tr = filter_trace (mis = None) tr in
+      let t1, t1' = may_prepare_expansion (tr = []) t1
+      and t2, t2' = may_prepare_expansion (tr = []) t2 in
+      print_labels := not !Clflags.classic;
+      let tr = List.map prepare_expansion tr in
+      fprintf ppf
+        "@[<v 0>\
+          @[<v 2>\
+            %t@,\
+            @[<2>%a@]\
+          @]@,\
+          @[<v 2>\
+            %t@,\
+            @[<2>%a@]\
+          @]\
+          %a\
+          %t\
+        @]"
+        txt1 (super_type_expansion ~tag:"error" t1) t1'
+        txt2 (super_type_expansion ~tag:"info" t2) t2'
+        super_trace tr
+        (explanation unif mis);
+      print_labels := true
+    with exn ->
+      print_labels := true;
+      raise exn
+end
+#end
 
 let report_unification_error ppf env ?(unif=true)
     tr txt1 txt2 =

vendor/ocaml/utils/misc.ml

@@ -376,6 +376,9 @@ module Color = struct
     | BG of color (* background *)
     | Bold
     | Reset
+#if undefined BS_NO_COMPILER_PATCH then
+    | Dim
+#end
 
   let ansi_of_color = function
     | Black -> "0"
@@ -392,6 +395,9 @@ module Color = struct
     | BG c -> "4" ^ ansi_of_color c
     | Bold -> "1"
     | Reset -> "0"
+#if undefined BS_NO_COMPILER_PATCH then
+    | Dim -> "2"
+#end
 
   let ansi_of_style_l l =
     let s = match l with
@@ -423,6 +429,11 @@ module Color = struct
     | "error" -> (!cur_styles).error
     | "warning" -> (!cur_styles).warning
     | "loc" -> (!cur_styles).loc
+#if undefined BS_NO_COMPILER_PATCH then
+    | "info" -> [Bold; FG Yellow]
+    | "dim" -> [Dim]
+    | "filename" -> [FG Cyan]
+#end
     | _ -> raise Not_found
 
   let color_enabled = ref true

vendor/ocaml/utils/misc.mli

@@ -188,6 +188,9 @@ module Color : sig
     | BG of color (* background *)
     | Bold
     | Reset
+#if undefined BS_NO_COMPILER_PATCH then
+    | Dim
+#end
 
   val ansi_of_style_l : style list -> string
   (* ANSI escape sequence for the given style *)