print polyvar tag names in ReScript syntax (#6348)

* print polyvar tag names in ReScript syntax

* changelog

* make reanalyze happy

CHANGELOG.md

@@ -23,6 +23,7 @@
 #### :nail_care: Polish
 - Conditionally print error message about record with missing label potentially being a component. https://github.com/rescript-lang/rescript-compiler/pull/6337
 - Put definition in the bottom and the actual error at the top when reporting errors for supplying fields etc with the wrong name. https://github.com/rescript-lang/rescript-compiler/pull/6336
+- Fix left over places where polyvariant tag names were printed in OCaml syntax instead of ReScript. https://github.com/rescript-lang/rescript-compiler/pull/6348
 
 # 11.0.0-beta.4
 

jscomp/build_tests/super_errors/expected/polyvariant_name_formatting.res.expected

@@ -0,0 +1,13 @@
+
+  We've found a bug for you!
+  /.../fixtures/polyvariant_name_formatting.res:6:3-10
+
+  4 │ 
+  5 │ switch f {
+  6 │ | #Invalid => ()
+  7 │ }
+  8 │ 
+
+  This pattern matches values of type [? #Invalid]
+  but a pattern was expected which matches values of type polyvariant
+  The second variant type does not allow tag(s) #Invalid

jscomp/build_tests/super_errors/fixtures/polyvariant_name_formatting.res

@@ -0,0 +1,7 @@
+type polyvariant = [#Error(string) | #Valid]
+
+let f: polyvariant = #Valid
+
+switch f {
+| #Invalid => ()
+}

jscomp/core/bs_conditional_initial.ml

@@ -52,8 +52,10 @@ let setup_env () =
 
     Rescript_cpp.replace_directive_bool "BS" true;
   Rescript_cpp.replace_directive_bool "JS" true;
+  Printtyp.print_res_poly_identifier := Res_printer.polyVarIdentToString;
   Rescript_cpp.replace_directive_string "BS_VERSION"  Bs_version.version
   (*; Switch.cut := 100*) (* tweakable but not very useful *)
+
 
 let () = 
   at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())

jscomp/gentype/EmitType.ml

@@ -163,13 +163,13 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
              type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType)
     in
     let noPayloadsRendered = noPayloads |> List.map labelJSToString in
-    let field ~name ?(docString = DocString.empty) value =
+    let field ~name value =
       {
         mutable_ = Mutable;
         nameJS = name;
         optional = Mandatory;
         type_ = TypeVar value;
-        docString;
+        docString = DocString.empty;
       }
     in
     let fields fields =

jscomp/ml/ctype.ml

@@ -65,7 +65,7 @@ let () =
           Some
             Location.
               (errorf ~loc:(in_file !input_name)
-                 "In this program,@ variant constructors@ `%s and `%s@ \
+                 "In this program,@ variant constructors@ #%s and #%s@ \
                   have the same hash value.@ Change one of them." l l'
               )
       | _ -> None

jscomp/ml/printtyp.ml

@@ -25,6 +25,8 @@ open Types
 open Btype
 open Outcometree
 
+let print_res_poly_identifier: (string -> string) ref = ref (fun _ -> assert false)
+
 (* Print a long identifier *)
 
 let rec longident ppf = function
@@ -1412,8 +1414,8 @@ let may_prepare_expansion compact (t, t') =
 let print_tags ppf fields =
   match fields with [] -> ()
   | (t, _) :: fields ->
-      fprintf ppf "`%s" t;
-      List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
+      fprintf ppf "%s" (!print_res_poly_identifier t);
+      List.iter (fun (t, _) -> fprintf ppf ",@ %s" (!print_res_poly_identifier t)) fields
 
 let has_explanation t3 t4 =
   match t3.desc, t4.desc with
@@ -1493,7 +1495,7 @@ let explanation unif t3 t4 ppf =
             "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
             print_tags fields
       | [l1,_], true, [l2,_], true when l1 = l2 ->
-          fprintf ppf "@,Types for tag `%s are incompatible" l1
+          fprintf ppf "@,Types for tag %s are incompatible" (!print_res_poly_identifier l1)
       | _ -> ()
       end
   | _ -> ()

jscomp/ml/printtyp.mli

@@ -19,6 +19,7 @@ open Format
 open Types
 open Outcometree
 
+val print_res_poly_identifier: (string -> string) ref
 val longident: formatter -> Longident.t -> unit
 val ident: formatter -> Ident.t -> unit
 val tree_of_path: Path.t -> out_ident

jscomp/ml/typetexp.ml

@@ -946,8 +946,8 @@ let report_error env ppf = function
       end
   | Variant_tags (lab1, lab2) ->
       fprintf ppf
-        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
-        lab1 lab2 "Change one of them."
+        "@[Variant tags %s@ and %s have the same hash value.@ %s@]"
+        (!Printtyp.print_res_poly_identifier lab1) (!Printtyp.print_res_poly_identifier lab2) "Change one of them."
   | Invalid_variable_name name ->
       fprintf ppf "The type variable name %s is not allowed in programs" name
   | Cannot_quantify (name, v) ->

jscomp/syntax/src/res_printer.ml

@@ -480,6 +480,10 @@ let printPolyVarIdent txt =
       | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""]
       | _ -> Doc.text txt)
 
+let polyVarIdentToString polyVarIdent =
+  Doc.concat [Doc.text "#"; printPolyVarIdent polyVarIdent]
+  |> Doc.toString ~width:80
+
 let printLident l =
   let flatLidOpt lid =
     let rec flat accu = function

jscomp/syntax/src/res_printer.mli

@@ -24,3 +24,5 @@ val printImplementation :
   width:int -> Parsetree.structure -> comments:Res_comment.t list -> string
 val printInterface :
   width:int -> Parsetree.signature -> comments:Res_comment.t list -> string
+
+val polyVarIdentToString : string -> string [@@live]