diff --git a/changes/coercion-into-private-type.breaking.md b/changes/coercion-into-private-type.breaking.md new file mode 100644 index 0000000000..0550398fe3 --- /dev/null +++ b/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. diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index b1326f398a..a5e13d267b 100644 --- a/compiler/ml/ctype.ml +++ b/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 *) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 09bea4bbb9..a8f50bb49b 100644 --- a/compiler/ml/ctype.mli +++ b/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 diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 69e77c2d17..bc7eacf5ef 100644 --- a/compiler/ml/printtyp.ml +++ b/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 + "@ @{%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 = diff --git a/tests/build_tests/super_errors/expected/coercion_into_private_record.res.expected b/tests/build_tests/super_errors/expected/coercion_into_private_record.res.expected new file mode 100644 index 0000000000..970a05b1be --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/coercion_into_private_record_from_private.res.expected b/tests/build_tests/super_errors/expected/coercion_into_private_record_from_private.res.expected new file mode 100644 index 0000000000..5b358c254e --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/coercion_into_private_unboxed_variant.res.expected b/tests/build_tests/super_errors/expected/coercion_into_private_unboxed_variant.res.expected new file mode 100644 index 0000000000..a717cc9341 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/coercion_into_private_variant.res.expected b/tests/build_tests/super_errors/expected/coercion_into_private_variant.res.expected new file mode 100644 index 0000000000..17fe22fe91 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/coercion_into_private_variant_from_polyvariant.res.expected b/tests/build_tests/super_errors/expected/coercion_into_private_variant_from_polyvariant.res.expected new file mode 100644 index 0000000000..01633422b4 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/coercion_into_private_record.res b/tests/build_tests/super_errors/fixtures/coercion_into_private_record.res new file mode 100644 index 0000000000..402da9b46a --- /dev/null +++ b/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.})) diff --git a/tests/build_tests/super_errors/fixtures/coercion_into_private_record_from_private.res b/tests/build_tests/super_errors/fixtures/coercion_into_private_record_from_private.res new file mode 100644 index 0000000000..4098d8011d --- /dev/null +++ b/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) diff --git a/tests/build_tests/super_errors/fixtures/coercion_into_private_unboxed_variant.res b/tests/build_tests/super_errors/fixtures/coercion_into_private_unboxed_variant.res new file mode 100644 index 0000000000..496477df5d --- /dev/null +++ b/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) diff --git a/tests/build_tests/super_errors/fixtures/coercion_into_private_variant.res b/tests/build_tests/super_errors/fixtures/coercion_into_private_variant.res new file mode 100644 index 0000000000..68039b312a --- /dev/null +++ b/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) diff --git a/tests/build_tests/super_errors/fixtures/coercion_into_private_variant_from_polyvariant.res b/tests/build_tests/super_errors/fixtures/coercion_into_private_variant_from_polyvariant.res new file mode 100644 index 0000000000..adee0c745b --- /dev/null +++ b/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) diff --git a/tests/tests/src/RecordCoercion.mjs b/tests/tests/src/RecordCoercion.mjs index 5db90d2501..432de399a9 100644 --- a/tests/tests/src/RecordCoercion.mjs +++ b/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 */ diff --git a/tests/tests/src/RecordCoercion.res b/tests/tests/src/RecordCoercion.res index edb5c08752..c4b363071d 100644 --- a/tests/tests/src/RecordCoercion.res +++ b/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 diff --git a/tests/tests/src/VariantCoercion.mjs b/tests/tests/src/VariantCoercion.mjs index 975ee646b7..0459f6047e 100644 --- a/tests/tests/src/VariantCoercion.mjs +++ b/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 */ diff --git a/tests/tests/src/VariantCoercion.res b/tests/tests/src/VariantCoercion.res index 69f9aca7d0..e659c34923 100644 --- a/tests/tests/src/VariantCoercion.res +++ b/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)