Keep @tag and runtime annotations when printing a type declaration

changes/print-type-annotations.fix.md

@@ -0,0 +1 @@
+- Keep `@tag`, `@notUndefined`, `@instanceOf` and `@typeOf` when printing a type declaration, in error messages, hover and generated interfaces.

compiler/ml/includecore.ml

@@ -201,7 +201,9 @@ let label side decl =
   in
   String.capitalize_ascii (side ^ " " ^ decl)
 
-let report_type_mismatch0 first second decl ppf err =
+(* [lead_in] introduces the two lines of a difference in runtime
+   representation; without it they stand under a lead-in printed before *)
+let report_type_mismatch0 ?(lead_in = true) first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
   match err with
   | Arity -> pr "They have different arities"
@@ -243,24 +245,41 @@ let report_type_mismatch0 first second decl ppf err =
   | Variant_representation s ->
     pr "The internal representations for case %s are not equal" (Ident.name s)
   | Not_undefined ->
-    pr
-      "@[<v 2>Their runtime representations differ:@,\
-       %s: can hold undefined@,\
-       %s: @notUndefined@]"
-      (label first decl) (label second decl)
+    if lead_in then pr "@[<v 2>Their runtime representations differ:@,";
+    pr "%s: can hold undefined@,%s: @notUndefined" (label first decl)
+      (label second decl);
+    if lead_in then pr "@]"
   | Runtime_annotation (declared1, declared2) ->
-    pr "@[<v 2>Their runtime representations differ:@,%s: %s@,%s: %s@]"
-      (label first decl) declared1 (label second decl) declared2
+    if lead_in then pr "@[<v 2>Their runtime representations differ:@,";
+    pr "%s: %s@,%s: %s" (label first decl) declared1 (label second decl)
+      declared2;
+    if lead_in then pr "@]"
 
-let report_type_mismatch first second decl ppf =
-  List.iter (fun err ->
-      match err with
-      | Manifest -> ()
-      (* Its lines are labels, not sentences *)
-      | Runtime_annotation _ | Not_undefined ->
-        Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
-      | _ ->
-        Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
+(* Each reason on a line after a break. [read_the_same] puts them under a note
+   that the declarations print the same, which then replaces the lead-in of a
+   difference in runtime representation. *)
+let report_type_mismatch ?(read_the_same = false) first second decl ppf errs =
+  let report ppf =
+    List.iter (fun err ->
+        match err with
+        | Manifest -> ()
+        (* Its lines are labels, not sentences *)
+        | Runtime_annotation _ | Not_undefined ->
+          Format.fprintf ppf "@ %a"
+            (report_type_mismatch0 ~lead_in:(not read_the_same) first second
+               decl)
+            err
+        | _ ->
+          Format.fprintf ppf "@ %a."
+            (report_type_mismatch0 first second decl)
+            err)
+  in
+  if read_the_same then
+    Format.fprintf ppf
+      "@ @[<v 2>The declarations read the same, but a type they mention \
+       differs:%a@]"
+      report errs
+  else report ppf errs
 
 let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
   match (arg1, arg2) with

compiler/ml/includecore.mli

@@ -67,4 +67,10 @@ val extension_constructors :
   Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool
 
 val report_type_mismatch :
-  string -> string -> string -> Format.formatter -> type_mismatch list -> unit
+  ?read_the_same:bool ->
+  string ->
+  string ->
+  string ->
+  Format.formatter ->
+  type_mismatch list ->
+  unit

compiler/ml/includemod.ml

@@ -583,8 +583,16 @@ let include_symptom ~swapped env ppf = function
         if swapped then ("the expected", "the actual")
         else ("the actual", "the expected")
       in
+      (* Declarations can print the same and still differ, when a type they
+         mention differs between the two sides, e.g. a class the interface
+         leaves abstract. The reasons then say that first. *)
+      let read_the_same =
+        Format.asprintf "%a" (type_declaration id) d1
+        = Format.asprintf "%a" (type_declaration id) d2
+      in
       fprintf ppf "@,%a"
-        (Includecore.report_type_mismatch first second "declaration")
+        (Includecore.report_type_mismatch ~read_the_same first second
+           "declaration")
         errs
   | Extension_constructors (id, x1, x2) ->
     show_declarations ~swapped (extension_constructor id) ppf

compiler/ml/outcometree.ml

@@ -70,8 +70,9 @@ and out_type_decl = {
   otype_params: (string * (bool * bool)) list;
   otype_type: out_type;
   otype_private: Asttypes.private_flag;
-  otype_immediate: bool;
-  otype_unboxed: bool;
+  otype_attributes: string list;
+      (** The annotations that change what the declaration means at run time,
+          as they are written, e.g. [@unboxed] or [@tag("kind")] *)
   otype_cstrs: (out_type * out_type) list;
 }
 and out_extension_constructor = {

compiler/ml/printtyp.ml

@@ -892,14 +892,35 @@ and tree_of_type_decl id decl =
         decl.type_private,
         decl.type_representation = Unboxed )
   in
-  let immediate = Builtin_attributes.immediate decl.type_attributes in
+  let attributes =
+    let flag set attribute = if set then [attribute] else [] in
+    (* A malformed annotation was reported when the declaration was typed *)
+    let stated process =
+      try process decl.type_attributes
+      with Ast_untagged_variants.Error _ -> None
+    in
+    List.concat
+      [
+        flag (Builtin_attributes.immediate decl.type_attributes) "@immediate";
+        flag unboxed "@unboxed";
+        (match stated Ast_untagged_variants.process_tag_name with
+        | Some name ->
+          [Printf.sprintf "@tag(\"%s\")" (String_literal.encode_js_string name)]
+        | None -> []);
+        (match
+           stated (Ast_untagged_variants.process_runtime_annotation ?loc:None)
+         with
+        | Some annotation ->
+          [Ast_untagged_variants.runtime_annotation_to_string annotation]
+        | None -> []);
+      ]
+  in
   {
     otype_name = name;
     otype_params = args;
     otype_type = ty;
     otype_private = priv;
-    otype_immediate = immediate;
-    otype_unboxed = unboxed;
+    otype_attributes = attributes;
     otype_cstrs = constraints;
   }
 

compiler/syntax/src/res_outcome_printer.ml

@@ -661,11 +661,10 @@ let rec print_out_sig_item_doc ?(print_name_as_is = false)
   | Osig_type (out_type_decl, out_rec_status) ->
     (* TODO: manifest ? *)
     let attrs =
-      match (out_type_decl.otype_immediate, out_type_decl.otype_unboxed) with
-      | false, false -> Doc.nil
-      | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line]
-      | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line]
-      | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line]
+      match out_type_decl.otype_attributes with
+      | [] -> Doc.nil
+      | attributes ->
+        Doc.concat [Doc.text (String.concat " " attributes); Doc.line]
     in
     let kw =
       Doc.text

tests/analysis_tests/tests/src/CreateInterfaceFunctor.res

@@ -32,3 +32,12 @@ module WithWire = (X: {}) => {
 }
 
 module Applied = WithWire({})
+
+// Types of an applied functor keep their @tag
+module type Type = {
+  type t
+}
+
+module Tagged = (X: Type) => {
+  @tag("kind") type wrapped = Value({value: X.t}) | Empty({reason: string})
+}

tests/analysis_tests/tests/src/CreateInterfaceFunctorUse.res

@@ -9,3 +9,7 @@ include CreateInterfaceFunctor.MakeSet({
   type t = float
   let compare = (a: float, b) => a < b ? -1 : a > b ? 1 : 0
 })
+
+module IntTagged = CreateInterfaceFunctor.Tagged({
+  type t = int
+})

tests/analysis_tests/tests/src/expected/CreateInterfaceFunctor.res.txt

@@ -33,4 +33,13 @@ module WithWire: (
 module Applied: {
   type t = {@as("wire") field: int}
 }
+module type Type = {
+  type t
+}
+module Tagged: (
+  X: Type,
+) =>
+{
+  @tag("kind") type wrapped = Value({value: X.t}) | Empty({reason: string})
+}
 

tests/analysis_tests/tests/src/expected/CreateInterfaceFunctorUse.res.txt

@@ -5,4 +5,7 @@ module StrSet: {
 }
 type t = array<float>
 let add: (t, float) => array<float>
+module IntTagged: {
+  @tag("kind") type wrapped = Value({value: int}) | Empty({reason: string})
+}
 

tests/build_tests/super_errors/expected/not_undefined_functor_argument.res.expected

@@ -15,7 +15,7 @@
     type t = option<int>
 
   Expected declaration (/.../fixtures/not_undefined_functor_argument.res:3:19-24):
-    type t
+    @notUndefined type t
 
   Their runtime representations differ:
     Actual declaration: can hold undefined

tests/build_tests/super_errors/expected/not_undefined_functor_parameter.res.expected

@@ -16,7 +16,7 @@
     type t = X.t
 
   Expected declaration (/.../fixtures/not_undefined_functor_parameter.res:7:19-24):
-    type t
+    @notUndefined type t
 
   Their runtime representations differ:
     Actual declaration: can hold undefined

tests/build_tests/super_errors/expected/runtime_annotation_interface_over_record.res.expected

@@ -15,7 +15,7 @@
     type t = {y: int}
 
   Expected declaration (/.../fixtures/runtime_annotation_interface_over_record.res:2:21-26):
-    type t
+    @typeOf("string") type t
 
   Their runtime representations differ:
     Actual declaration: typeof "object"

tests/build_tests/super_errors/expected/tag_name_escaped.res.expected

@@ -0,0 +1,20 @@
+
+  We've found a bug for you!
+  /.../fixtures/tag_name_escaped.res:5:5-7:1
+
+  3 │ module M: {
+  4 │   @tag("k\"ind") type t = A({x: int}) | B({y: int})
+  5 │ } = {
+  6 │   @tag("typ\\é") type t = A({x: int}) | B({y: int})
+  7 │ }
+  8 │ 
+
+  Signature mismatch:
+
+  Actual declaration (/.../fixtures/tag_name_escaped.res:6:18-51):
+    @tag("typ\\é") type t = A({x: int}) | B({y: int})
+
+  Expected declaration (/.../fixtures/tag_name_escaped.res:4:18-51):
+    @tag("k\"ind") type t = A({x: int}) | B({y: int})
+
+  Their @tag annotations differ.

tests/build_tests/super_errors/fixtures/tag_name_escaped.res

@@ -0,0 +1,7 @@
+// A @tag name with a quote, a backslash or non-ASCII letters prints as it is
+// written in source
+module M: {
+  @tag("k\"ind") type t = A({x: int}) | B({y: int})
+} = {
+  @tag("typ\\é") type t = A({x: int}) | B({y: int})
+}

tests/build_tests/super_errors_multi/expected/Cross_not_undefined_option_implementation.expected

@@ -14,7 +14,7 @@
     type t = option<int>
 
   Expected declaration (/.../fixtures/Cross_not_undefined_option_implementation/Hidden.resi:1:15-20):
-    type t
+    @notUndefined type t
 
   Their runtime representations differ:
     Actual declaration: can hold undefined

tests/build_tests/super_errors_multi/expected/Cross_runtime_annotation_claimed_by_interface.expected

@@ -13,7 +13,7 @@
     type t = option<string>
 
   Expected declaration (/.../fixtures/Cross_runtime_annotation_claimed_by_interface/Claim.resi:1:19-24):
-    type t
+    @typeOf("string") type t
 
   Their runtime representations differ:
     Actual declaration: no stated class or typeof

tests/build_tests/super_errors_multi/expected/Cross_runtime_annotation_functor_argument.expected

@@ -11,10 +11,10 @@
   Signature mismatch:
 
   Actual declaration (/.../fixtures/Cross_runtime_annotation_functor_argument/A_classes.res:2:20-44):
-    type dog = A_classes.dog
+    @instanceOf("Dog") type dog = A_classes.dog
 
   Expected declaration (/.../fixtures/Cross_runtime_annotation_functor_argument/B_user.res:4:24-31):
-    type dog
+    @instanceOf("Dog") type dog
 
   Their runtime representations differ:
     Actual declaration: instances of Dog, a subclass of Animal

tests/build_tests/super_errors_multi/expected/Cross_runtime_annotation_hidden_base.expected

@@ -11,11 +11,11 @@
   does not match the interface /.../fixtures/Cross_runtime_annotation_hidden_base/classes.cmi:
 
   Actual declaration (/.../fixtures/Cross_runtime_annotation_hidden_base/Classes.res:2:20-44):
-    type dog = private animal
+    @instanceOf("Dog") type dog = private animal
 
   Expected declaration (/.../fixtures/Cross_runtime_annotation_hidden_base/Classes.resi:2:20-44):
-    type dog = private animal
+    @instanceOf("Dog") type dog = private animal
 
-  Their runtime representations differ:
+  The declarations read the same, but a type they mention differs:
     Actual declaration: instances of Dog, a subclass of Animal
     Expected declaration: instances of Dog

tests/build_tests/super_errors_multi/expected/Cross_runtime_annotation_hidden_superclass.expected

@@ -11,10 +11,10 @@
   does not match the interface /.../fixtures/Cross_runtime_annotation_hidden_superclass/classes.cmi:
 
   Actual declaration (/.../fixtures/Cross_runtime_annotation_hidden_superclass/Classes.res:2:20-44):
-    type dog = private animal
+    @instanceOf("Dog") type dog = private animal
 
   Expected declaration (/.../fixtures/Cross_runtime_annotation_hidden_superclass/Classes.resi:2:20-27):
-    type dog
+    @instanceOf("Dog") type dog
 
   Their runtime representations differ:
     Actual declaration: instances of Dog, a subclass of Animal

tests/build_tests/super_errors_multi/expected/Iface_tag_name_mismatch.expected

@@ -13,9 +13,9 @@
   does not match the interface /.../fixtures/Iface_tag_name_mismatch/foo.cmi:
 
   Actual declaration (/.../fixtures/Iface_tag_name_mismatch/Foo.res:2:1-4:5):
-    type t = @as("a") A | B
+    @tag("type") type t = @as("a") A | B
 
   Expected declaration (/.../fixtures/Iface_tag_name_mismatch/Foo.resi:2:1-4:5):
-    type t = @as("a") A | B
+    @tag("kind") type t = @as("a") A | B
 
   Their @tag annotations differ.