From 052d3cca9e335047fe8adbeaec3b11e01e270917 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 29 Oct 2026 10:11:53 +0000 Subject: [PATCH] Refuse coercing another type into a private record or variant Why: A private type's values can only be built in the module that defines it, but structural coercion built them anywhere: a plain record, another module's private record with the same fields, a variant, a polymorphic variant or a string coerced into a private record or variant (#9124). `subtype_rec` refuses a coercion whose target's definition is a private record or variant unless the source is that same type. Coercing out of a private type is unchanged. Typing modified (coercion into a private type): Example: module Blob: { type t = private {size: float} } = { type t = {size: float} } type plain = {size: float} let fake = (p: plain) => (p :> Blob.t) Before (rule): a record coerces into a record with compatible fields, private or not After (rule): a record or variant coerces into a private record or variant only from that same type Diagnostic added (coercion into a private type): Example: let fake = (p: plain) => (p :> Blob.t) Before (diagnostic): none After (diagnostic): 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. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Claude-Session: https://claude.ai/code/session_01Kr4cjoUi2f5VpMvE6wT9bo Signed-off-by: Christoph Knittel --- .../coercion-into-private-type.breaking.md | 1 + compiler/ml/ctype.ml | 29 +++++++++++++++++++ compiler/ml/ctype.mli | 3 ++ compiler/ml/printtyp.ml | 7 ++++- .../coercion_into_private_record.res.expected | 14 +++++++++ ...o_private_record_from_private.res.expected | 12 ++++++++ ..._into_private_unboxed_variant.res.expected | 12 ++++++++ ...coercion_into_private_variant.res.expected | 12 ++++++++ ...vate_variant_from_polyvariant.res.expected | 12 ++++++++ .../fixtures/coercion_into_private_record.res | 13 +++++++++ ...rcion_into_private_record_from_private.res | 16 ++++++++++ .../coercion_into_private_unboxed_variant.res | 6 ++++ .../coercion_into_private_variant.res | 8 +++++ ..._into_private_variant_from_polyvariant.res | 6 ++++ tests/tests/src/RecordCoercion.mjs | 27 +++++++++++++++++ tests/tests/src/RecordCoercion.res | 16 ++++++++++ tests/tests/src/VariantCoercion.mjs | 18 ++++++++++++ tests/tests/src/VariantCoercion.res | 16 ++++++++++ 18 files changed, 227 insertions(+), 1 deletion(-) create mode 100644 changes/coercion-into-private-type.breaking.md create mode 100644 tests/build_tests/super_errors/expected/coercion_into_private_record.res.expected create mode 100644 tests/build_tests/super_errors/expected/coercion_into_private_record_from_private.res.expected create mode 100644 tests/build_tests/super_errors/expected/coercion_into_private_unboxed_variant.res.expected create mode 100644 tests/build_tests/super_errors/expected/coercion_into_private_variant.res.expected create mode 100644 tests/build_tests/super_errors/expected/coercion_into_private_variant_from_polyvariant.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/coercion_into_private_record.res create mode 100644 tests/build_tests/super_errors/fixtures/coercion_into_private_record_from_private.res create mode 100644 tests/build_tests/super_errors/fixtures/coercion_into_private_unboxed_variant.res create mode 100644 tests/build_tests/super_errors/fixtures/coercion_into_private_variant.res create mode 100644 tests/build_tests/super_errors/fixtures/coercion_into_private_variant_from_polyvariant.res diff --git a/changes/coercion-into-private-type.breaking.md b/changes/coercion-into-private-type.breaking.md new file mode 100644 index 00000000000..0550398fe31 --- /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 b1326f398a7..a5e13d267b0 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 09bea4bbb9c..a8f50bb49b6 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 69e77c2d17a..bc7eacf5ef6 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 00000000000..970a05b1be0 --- /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 00000000000..5b358c254e4 --- /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 00000000000..a717cc9341e --- /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 00000000000..17fe22fe918 --- /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 00000000000..01633422b48 --- /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 00000000000..402da9b46af --- /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 00000000000..4098d8011de --- /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 00000000000..496477df5db --- /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 00000000000..68039b312a3 --- /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 00000000000..adee0c745b8 --- /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 5db90d25013..432de399a96 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 edb5c087528..c4b363071d1 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 975ee646b76..0459f6047e4 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 69f9aca7d0b..e659c349239 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)