Refuse coercing another type into a private record or variant

changes/coercion-into-private-type.breaking.md

@@ -0,0 +1 @@
+- Coercing another type into a private record or variant is an error: only the module defining a private type can build its values. Coercing out of a private type still works.

compiler/ml/ctype.ml

@@ -87,6 +87,7 @@ type subtype_context =
       right_record_name: Path.t;
       issues: Record_coercion.record_field_subtype_violation list;
     }
+  | Coercion_into_private_type of {typename: Path.t}
 
 exception Subtype of type_pairs * type_pairs * subtype_context option
 
@@ -3500,6 +3501,20 @@ let extract_concrete_typedecl_opt env t =
   | v -> Some v
   | exception Not_found -> None
 
+(* Whether [t2] is a private record or variant that [t1], another type, would
+   be coerced into *)
+let coerces_into_private_type env t1 t2 =
+  match extract_concrete_typedecl_opt env t2 with
+  | Some
+      ( p2,
+        _,
+        {type_private = Private; type_kind = Type_record _ | Type_variant _} )
+    -> (
+    match extract_concrete_typedecl_opt env t1 with
+    | Some (p1, _, _) -> not (Path.same p1 p2)
+    | None -> true)
+  | Some _ | None -> false
+
 let rec subtype_rec env trace t1 t2 cstrs =
   let t1 = repr t1 in
   let t2 = repr t2 in
@@ -3564,6 +3579,20 @@ let rec subtype_rec env trace t1 t2 cstrs =
           (trace, t1, t2, !(current_univar_pairs ()), None) :: cstrs)
       | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+      | _, Tconstr _ when coerces_into_private_type env t1 t2 ->
+        (* Only the module defining a private record or variant builds its
+           values; a coercion from another type would build one anywhere *)
+        let typename =
+          match extract_concrete_typedecl_opt env t2 with
+          | Some (p2, _, _) -> p2
+          | None -> assert false
+        in
+        ( trace,
+          t1,
+          t2,
+          !(current_univar_pairs ()),
+          Some (Coercion_into_private_type {typename}) )
+        :: cstrs
       | Tconstr (p1, [], _), Tconstr (p2, [], _)
         when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float ->
         (* Int can always be coerced to float *)

compiler/ml/ctype.mli

@@ -51,6 +51,9 @@ type subtype_context =
       right_record_name: Path.t;
       issues: Record_coercion.record_field_subtype_violation list;
     }  (** Records have fields that are not compatible. *)
+  | Coercion_into_private_type of {typename: Path.t}
+      (** The target is a private record or variant, whose values only its own
+          module can build. *)
 
 type type_pairs = (type_expr * type_expr) list
 exception Unify of type_pairs

compiler/ml/printtyp.ml

@@ -1789,7 +1789,12 @@ let report_subtyping_error ppf env tr1 txt1 tr2 ctx =
               fprintf ppf "@ - ";
               print_record_field_subtype_violation ppf issue ~left_record_name
                 ~right_record_name)
-            issues)
+            issues
+        | Coercion_into_private_type {typename} ->
+          fprintf ppf
+            "@ @{<info>%s@} is private: its values can only be built in the \
+             module that defines it, so another type cannot be coerced to it."
+            (Path.name typename))
       | None -> ())
 
 let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =

tests/build_tests/super_errors/expected/coercion_into_private_record.res.expected

@@ -0,0 +1,14 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_into_private_record.res:12:35-45
+
+  10 │ 
+  11 │ // A plain record coerced into a private one: constructs a Blob.t from 
+     │ outside
+  12 │ let fake = (p: plain): Blob.t => (p :> Blob.t)
+  13 │ let s = Blob.size(fake({size: 1.}))
+  14 │ 
+
+  Type plain is not a subtype of Blob.t 
+
+  Blob.t is private: its values can only be built in the module that defines it, so another type cannot be coerced to it.

tests/build_tests/super_errors/expected/coercion_into_private_record_from_private.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_into_private_record_from_private.res:16:15-37
+
+  14 │ }
+  15 │ 
+  16 │ let forged = (Fake.make(1.) :> Blob.t)
+  17 │ 
+
+  Type Fake.t is not a subtype of Blob.t 
+
+  Blob.t is private: its values can only be built in the module that defines it, so another type cannot be coerced to it.

tests/build_tests/super_errors/expected/coercion_into_private_unboxed_variant.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_into_private_unboxed_variant.res:6:19-29
+
+  4 │   @unboxed type t = Text(string) | Number(int)
+  5 │ }
+  6 │ let fromString = ("a" :> Id.t)
+  7 │ 
+
+  Type string is not a subtype of Id.t 
+
+  Id.t is private: its values can only be built in the module that defines it, so another type cannot be coerced to it.

tests/build_tests/super_errors/expected/coercion_into_private_variant.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_into_private_variant.res:8:16-37
+
+  6 │ 
+  7 │ type plain = Red | Green
+  8 │ let forged = ((Red: plain) :> Color.t)
+  9 │ 
+
+  Type plain is not a subtype of Color.t 
+
+  Color.t is private: its values can only be built in the module that defines it, so another type cannot be coerced to it.

tests/build_tests/super_errors/expected/coercion_into_private_variant_from_polyvariant.res.expected

@@ -0,0 +1,12 @@
+
+  We've found a bug for you!
+  /.../fixtures/coercion_into_private_variant_from_polyvariant.res:6:18-41
+
+  4 │   type t = Red | Green
+  5 │ }
+  6 │ let fromPoly = ((#Red: [#Red]) :> Color.t)
+  7 │ 
+
+  Type [#Red] is not a subtype of Color.t 
+
+  Color.t is private: its values can only be built in the module that defines it, so another type cannot be coerced to it.

tests/build_tests/super_errors/fixtures/coercion_into_private_record.res

@@ -0,0 +1,13 @@
+module Blob: {
+  type t = private {size: float}
+  let size: t => float
+} = {
+  type t = {size: float}
+  let size = b => b.size
+}
+
+type plain = {size: float}
+
+// A plain record coerced into a private one: constructs a Blob.t from outside
+let fake = (p: plain): Blob.t => (p :> Blob.t)
+let s = Blob.size(fake({size: 1.}))

tests/build_tests/super_errors/fixtures/coercion_into_private_record_from_private.res

@@ -0,0 +1,16 @@
+module Blob: {
+  type t = private {size: float}
+} = {
+  type t = {size: float}
+}
+
+// Another private record with the same fields, constructed inside its own module
+module Fake: {
+  type t = private {size: float}
+  let make: float => t
+} = {
+  type t = {size: float}
+  let make = size => {size: size}
+}
+
+let forged = (Fake.make(1.) :> Blob.t)

tests/build_tests/super_errors/fixtures/coercion_into_private_unboxed_variant.res

@@ -0,0 +1,6 @@
+module Id: {
+  @unboxed type t = private Text(string) | Number(int)
+} = {
+  @unboxed type t = Text(string) | Number(int)
+}
+let fromString = ("a" :> Id.t)

tests/build_tests/super_errors/fixtures/coercion_into_private_variant.res

@@ -0,0 +1,8 @@
+module Color: {
+  type t = private Red | Green
+} = {
+  type t = Red | Green
+}
+
+type plain = Red | Green
+let forged = ((Red: plain) :> Color.t)

tests/build_tests/super_errors/fixtures/coercion_into_private_variant_from_polyvariant.res

@@ -0,0 +1,6 @@
+module Color: {
+  type t = private Red | Green
+} = {
+  type t = Red | Green
+}
+let fromPoly = ((#Red: [#Red]) :> Color.t)

tests/tests/src/RecordCoercion.mjs

@@ -11,7 +11,34 @@ let TestInlining = {
   name: "a"
 };
 
+function make(size) {
+  return {
+    size: size
+  };
+}
+
+let PrivateBlob = {
+  make: make
+};
+
+function blobToPlain(b) {
+  return b;
+}
+
+function blobToItself(b) {
+  return b;
+}
+
+let blobSize = 2;
+
+let PrivateBlob$make = make;
+
 export {
   TestInlining,
+  PrivateBlob,
+  blobToPlain,
+  blobToItself,
+  blobSize,
+  PrivateBlob$make,
 }
 /* No side effect */

tests/tests/src/RecordCoercion.res

@@ -31,3 +31,19 @@ module TestInlining = {
 
   let name = (a :> b).name
 }
+
+// A private record coerces into a plain one, and into itself, but nothing
+// coerces into it from another type
+module PrivateBlob: {
+  type t = private {size: float}
+  let make: float => t
+} = {
+  type t = {size: float}
+  let make = size => {size: size}
+}
+
+type plainBlob = {size: float}
+
+let blobToPlain = (b: PrivateBlob.t): plainBlob => (b :> plainBlob)
+let blobToItself = (b: PrivateBlob.t) => (b :> PrivateBlob.t)
+let blobSize = blobToPlain(PrivateBlob.make(2.)).size

tests/tests/src/VariantCoercion.mjs

@@ -104,6 +104,18 @@ let CoerceVariantBinaryOp = {
   z: z
 };
 
+let PrivateColor = {
+  red: "Red"
+};
+
+function colorToPlain(c) {
+  return c;
+}
+
+function colorToString(c) {
+  return c;
+}
+
 let a$2 = "Three";
 
 let b = "Three";
@@ -116,6 +128,8 @@ let ii = 1.1;
 
 let dd = 1.1;
 
+let redName = "Red";
+
 export {
   a$2 as a,
   b,
@@ -131,5 +145,9 @@ export {
   CoerceFromBigintToVariant,
   CoerceFromPolyvariantToVariant,
   CoerceVariantBinaryOp,
+  PrivateColor,
+  colorToPlain,
+  colorToString,
+  redName,
 }
 /*  Not a pure module */

tests/tests/src/VariantCoercion.res

@@ -150,3 +150,19 @@ module CoerceVariantBinaryOp = {
 
   let z = (X :> float) +. (Y :> float) +. 1.5
 }
+
+// A private variant coerces out of itself, but nothing coerces into it from
+// another type
+module PrivateColor: {
+  type t = private Red | Green
+  let red: t
+} = {
+  type t = Red | Green
+  let red = Red
+}
+
+type plainColor = Red | Green
+
+let colorToPlain = (c: PrivateColor.t): plainColor => (c :> plainColor)
+let colorToString = (c: PrivateColor.t) => (c :> string)
+let redName = colorToString(PrivateColor.red)