From 14f22458dc5944f87324cf34488b0fa1ff45b0c8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 27 Aug 2026 14:42:29 +0200 Subject: [PATCH 01/13] Pin current object-field mutability behavior ahead of representation cleanup Add behavior-pinning tests for the structural-object mutability semantics (currently encoded via phantom "x#=" setter members), ahead of the staged representation cleanup proposed in #8584. tests/tests/src/object_mutability_pin.res pins the compiling cases: closed mutable-to-immutable covariance, open-source and open-target coercions, assignment- and coercion-driven strengthening of open rows, and a generalized getter used at both mutabilities. Two cases are marked EXPECTED TO FLIP with the rationale in place: the unequal-type coercion and the unrelated-type assignment (getter int acquiring setter string), which today produces a value of declared type int that is the string "hello" at runtime - the type-preservation failure the cleanup closes. Seven super_errors fixtures pin the rejecting directions: closed-row writes, both-open invariance, readonly-to-mutable coercions, mutable-to-mutable invariance with unequal types, read-only callers against strengthened rows, and writes after a closed-source-to-open-target coercion. Part of #8584. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- ...ject_coercion_mutable_unequal.res.expected | 12 +++ .../object_coercion_open_open.res.expected | 14 ++++ ...rcion_promote_readonly_caller.res.expected | 13 +++ ..._coercion_readonly_to_mutable.res.expected | 10 +++ ...ct_open_write_readonly_caller.res.expected | 13 +++ ...te_after_open_target_coercion.res.expected | 12 +++ .../object_write_closed_row.res.expected | 11 +++ .../object_coercion_mutable_unequal.res | 8 ++ .../fixtures/object_coercion_open_open.res | 9 +++ ...bject_coercion_promote_readonly_caller.res | 11 +++ .../object_coercion_readonly_to_mutable.res | 6 ++ .../object_open_write_readonly_caller.res | 8 ++ ...bject_write_after_open_target_coercion.res | 13 +++ .../fixtures/object_write_closed_row.res | 6 ++ tests/tests/src/object_mutability_pin.mjs | 62 +++++++++++++++ tests/tests/src/object_mutability_pin.res | 79 +++++++++++++++++++ 16 files changed, 287 insertions(+) create mode 100644 tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_coercion_open_open.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_closed_row.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_coercion_mutable_unequal.res create mode 100644 tests/build_tests/super_errors/fixtures/object_coercion_open_open.res create mode 100644 tests/build_tests/super_errors/fixtures/object_coercion_promote_readonly_caller.res create mode 100644 tests/build_tests/super_errors/fixtures/object_coercion_readonly_to_mutable.res create mode 100644 tests/build_tests/super_errors/fixtures/object_open_write_readonly_caller.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_after_open_target_coercion.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_closed_row.res create mode 100644 tests/tests/src/object_mutability_pin.mjs create mode 100644 tests/tests/src/object_mutability_pin.res diff --git a/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected b/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected new file mode 100644 index 0000000000..1f15ef2292 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/object_coercion_mutable_unequal.res:8:35-57 + + 6 │ type wide = {"a": int, "b": int} + 7 │ type narrow = {"a": int} + 8 │ let p = (v: {@set "x": wide}) => (v :> {@set "x": narrow}) + 9 │ + + Type {"x": wide, "x#=": wide => unit} is not a subtype of + {"x": narrow, "x#=": narrow => unit} + Type narrow = {"a": int} is not a subtype of wide = {"a": int, "b": int} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_open_open.res.expected b/tests/build_tests/super_errors/expected/object_coercion_open_open.res.expected new file mode 100644 index 0000000000..73454f2319 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_coercion_open_open.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/object_coercion_open_open.res:9:32-51 + + 7 │ type wide = {"a": int, "b": int} + 8 │ type narrow = {"a": int} + 9 │ let p = (o: {.."x": wide}) => (o :> {.."x": narrow}) + 10 │ + + Type {.."x": wide} is not a subtype of {.."x": narrow} + Type wide = {"a": int, "b": int} is not compatible with type + narrow = {"a": int} + + The second object is expected to have a field "b" of type int, but it does not. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected b/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected new file mode 100644 index 0000000000..7d96ef7066 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/object_coercion_promote_readonly_caller.res:11:11-18 + + 9 │ let f = (o: {.."x": wide}) => (o :> {@set "x": wide}) + 10 │ @val external readonly: {"x": wide} = "readonly" + 11 │ let _ = f(readonly) + 12 │ + + This has type: {"x": wide} + But this function argument is expecting: {.."x": wide, "x#=": wide => unit} + + The first object is expected to have a field "x#=" of type wide => unit, but it does not. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected b/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected new file mode 100644 index 0000000000..8a305177c1 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/object_coercion_readonly_to_mutable.res:6:20-39 + + 4 │ See docs/object_representation_cleanup.md. */ + 5 │ type t = {"x": int} + 6 │ let p = (v: t) => (v :> {@set "x": int}) + 7 │ + + Type t = {"x": int} is not a subtype of {"x": int, "x#=": int => unit} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected b/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected new file mode 100644 index 0000000000..feb96929f8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/object_open_write_readonly_caller.res:8:11-18 + + 6 │ let f = (o: {.."x": int}) => o["x"] = 1 + 7 │ @val external readonly: {"x": int} = "readonly" + 8 │ let _ = f(readonly) + 9 │ + + This has type: {"x": int} + But this function argument is expecting: {.."x": int, "x#=": int => unit} + + The first object is expected to have a field "x#=" of type int => unit, but it does not. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected b/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected new file mode 100644 index 0000000000..1a830e566b --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/object_write_after_open_target_coercion.res:12:3 + + 10 │ let p = (v: {"x": wide}) => { + 11 │ let r = (v :> {.."x": narrow}) + 12 │ r["x"] = {"a": 1} + 13 │ } + 14 │ + + This expression has type {"x": narrow} + It has no field x#= \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected b/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected new file mode 100644 index 0000000000..47f058fd0d --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/object_write_closed_row.res:6:28 + + 4 │ See docs/object_representation_cleanup.md; compiling counterparts in + 5 │ tests/tests/src/object_mutability_pin.res. */ + 6 │ let g = (o: {"x": int}) => o["x"] = 1 + 7 │ + + This expression has type {"x": int} + It has no field x#= \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/object_coercion_mutable_unequal.res b/tests/build_tests/super_errors/fixtures/object_coercion_mutable_unequal.res new file mode 100644 index 0000000000..56eab51928 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_coercion_mutable_unequal.res @@ -0,0 +1,8 @@ +/* Pin (object mutability cleanup): mutable-to-mutable coercion is invariant + in the field type — with unequal types it is rejected (today the setter + member demands contravariance while the getter demands covariance). Must + stay an error under the new model (Mutable A <: Mutable B iff A = B). + See docs/object_representation_cleanup.md. */ +type wide = {"a": int, "b": int} +type narrow = {"a": int} +let p = (v: {@set "x": wide}) => (v :> {@set "x": narrow}) diff --git a/tests/build_tests/super_errors/fixtures/object_coercion_open_open.res b/tests/build_tests/super_errors/fixtures/object_coercion_open_open.res new file mode 100644 index 0000000000..34824e62c6 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_coercion_open_open.res @@ -0,0 +1,9 @@ +/* Pin (object mutability cleanup): when BOTH rows are open, object fields + are invariant — this covariant coercion is rejected. Principled, not an + artifact: an open result is a promotable result, and a covariantly + weakened field must never remain promotable (a later write at the narrow + type would reach readers at the wide type). Must stay an error under the + new model. See docs/object_representation_cleanup.md. */ +type wide = {"a": int, "b": int} +type narrow = {"a": int} +let p = (o: {.."x": wide}) => (o :> {.."x": narrow}) diff --git a/tests/build_tests/super_errors/fixtures/object_coercion_promote_readonly_caller.res b/tests/build_tests/super_errors/fixtures/object_coercion_promote_readonly_caller.res new file mode 100644 index 0000000000..63579a6b8e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_coercion_promote_readonly_caller.res @@ -0,0 +1,11 @@ +/* Pin (object mutability cleanup): COERCION-driven strengthening (as + opposed to the assignment-driven case in + object_open_write_readonly_caller.res): coercing an open-row parameter to + a same-type mutable target constrains the row, so a read-only caller is + rejected. Both halves must survive the new model (the coercion promotes + the open source's field; the demand becomes a Mutable field). + See docs/object_representation_cleanup.md. */ +type wide = {"a": int, "b": int} +let f = (o: {.."x": wide}) => (o :> {@set "x": wide}) +@val external readonly: {"x": wide} = "readonly" +let _ = f(readonly) diff --git a/tests/build_tests/super_errors/fixtures/object_coercion_readonly_to_mutable.res b/tests/build_tests/super_errors/fixtures/object_coercion_readonly_to_mutable.res new file mode 100644 index 0000000000..451b43ba01 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_coercion_readonly_to_mutable.res @@ -0,0 +1,6 @@ +/* Pin (object mutability cleanup): a closed read-only field cannot be + coerced to a settable one — write capability cannot be conjured. Must + stay an error under the new model (closed row: no promotion). + See docs/object_representation_cleanup.md. */ +type t = {"x": int} +let p = (v: t) => (v :> {@set "x": int}) diff --git a/tests/build_tests/super_errors/fixtures/object_open_write_readonly_caller.res b/tests/build_tests/super_errors/fixtures/object_open_write_readonly_caller.res new file mode 100644 index 0000000000..53ceb57788 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_open_write_readonly_caller.res @@ -0,0 +1,8 @@ +/* Pin (object mutability cleanup): writing a bare field of an OPEN row is + accepted but strengthens the function's demand — callers must supply a + writable field, so a read-only argument is rejected. Both halves must + survive the new model (write = promotion on the open row; the demand + becomes a Mutable field). See docs/object_representation_cleanup.md. */ +let f = (o: {.."x": int}) => o["x"] = 1 +@val external readonly: {"x": int} = "readonly" +let _ = f(readonly) diff --git a/tests/build_tests/super_errors/fixtures/object_write_after_open_target_coercion.res b/tests/build_tests/super_errors/fixtures/object_write_after_open_target_coercion.res new file mode 100644 index 0000000000..836ae8bee6 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_after_open_target_coercion.res @@ -0,0 +1,13 @@ +/* Pin (object mutability cleanup): coercing a CLOSED source to an open + target yields a result whose row tail is instantiated from the source, + i.e. closed — so a subsequent write is rejected (the error even prints + the result type as the closed {"x": narrow}). This is what makes the + covariant closed-source/open-target coercion sound: the result is not + promotable. Must stay an error under the new model. + See docs/object_representation_cleanup.md. */ +type wide = {"a": int, "b": int} +type narrow = {"a": int} +let p = (v: {"x": wide}) => { + let r = (v :> {.."x": narrow}) + r["x"] = {"a": 1} +} diff --git a/tests/build_tests/super_errors/fixtures/object_write_closed_row.res b/tests/build_tests/super_errors/fixtures/object_write_closed_row.res new file mode 100644 index 0000000000..e3503b9403 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_closed_row.res @@ -0,0 +1,6 @@ +/* Pin (object mutability cleanup): writing a bare field of a CLOSED object + row is an error — the row cannot acquire a setter. Must stay an error + under the new model (Immutable field in a closed row cannot be promoted). + See docs/object_representation_cleanup.md; compiling counterparts in + tests/tests/src/object_mutability_pin.res. */ +let g = (o: {"x": int}) => o["x"] = 1 diff --git a/tests/tests/src/object_mutability_pin.mjs b/tests/tests/src/object_mutability_pin.mjs new file mode 100644 index 0000000000..6b19aba79d --- /dev/null +++ b/tests/tests/src/object_mutability_pin.mjs @@ -0,0 +1,62 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function forget_write_covariant(v) { + return v; +} + +function open_source_covariant(o) { + return o; +} + +function closed_source_open_target(v) { + return v; +} + +function open_source_promote_same_type(o) { + return o; +} + +function open_row_write(o) { + o.x = 1; +} + +function read_x(obj) { + return obj.x; +} + +function read_from_settable() { + return settableObj.x; +} + +function read_from_readonly() { + return readonlyObj.x; +} + +function open_source_setter_narrower(o) { + return o; +} + +function unrelated_setter_type(o) { + o.x = "hello"; + return o.x; +} + +function run_unrelated_setter() { + return unrelated_setter_type(plainIntObj); +} + +export { + forget_write_covariant, + open_source_covariant, + closed_source_open_target, + open_source_promote_same_type, + open_row_write, + read_x, + read_from_settable, + read_from_readonly, + open_source_setter_narrower, + unrelated_setter_type, + run_unrelated_setter, +} +/* No side effect */ diff --git a/tests/tests/src/object_mutability_pin.res b/tests/tests/src/object_mutability_pin.res new file mode 100644 index 0000000000..97a15cf900 --- /dev/null +++ b/tests/tests/src/object_mutability_pin.res @@ -0,0 +1,79 @@ +/* Pins the current typing behavior of object-field mutability (encoded today + as phantom `"x#="` setter members) ahead of the representation cleanup + described in docs/object_representation_cleanup.md. + + Every case in this file compiles today. The ones marked EXPECTED TO FLIP + are intentionally rejected by the new model (single storage location: a + field has one type; promotion only adds write capability, it never + changes the type). The others must keep compiling unchanged. + + The rejecting counterparts are pinned in + tests/build_tests/super_errors/fixtures/object_*.res. */ + +type wide = {"a": int, "b": int} +type narrow = {"a": int} /* wide <: narrow (width subtyping) */ + +/* Closed rows: coercion may forget write capability, covariantly. + (Mutable A :> Immutable B with A <: B.) */ +let forget_write_covariant = (v: {@set "x": wide}): {"x": narrow} => (v :> {"x": narrow}) + +/* Open source, closed immutable target: ordinary covariance. Sound forever: + the coerced alias is read-only, and a later promotion of the source + writes at the source's own field type. */ +let open_source_covariant = (o: {.."x": wide}): {"x": narrow} => (o :> {"x": narrow}) + +/* Closed source, open target: covariant; the target's tail is instantiated + from the (closed) source, so the result is not promotable. */ +let closed_source_open_target = (v: {"x": wide}) => (v :> {.."x": narrow}) + +/* Open source, mutable target at the SAME type: accepted, and constrains + callers to writable objects (today: absorbs the "x#=" member; new model: + promotion Immutable -> Mutable at the same type). */ +let open_source_promote_same_type = (o: {.."x": wide}): {@set "x": wide} => (o :> {@set "x": wide}) + +/* Writing a bare field of an open row is accepted and strengthens the + demand on callers (today: adds "x#=" through the tail; new model: + promotion). The rejection of a read-only caller is pinned in + object_open_write_readonly_caller.res. */ +let open_row_write = (o: {.."x": int}) => o["x"] = 1 + +/* A generalized getter accepts both read-only and settable objects. */ +let read_x = obj => obj["x"] + +@val external settable_obj: {@set "x": wide} = "settableObj" +@val external readonly_obj: {"x": wide} = "readonlyObj" + +let read_from_settable = (): wide => read_x(settable_obj) +let read_from_readonly = (): wide => read_x(readonly_obj) + +/* EXPECTED TO FLIP: today an open row can acquire a setter at a DIFFERENT + type than its getter, because writability is a separate member — this + coercion leaves getter type `wide` and setter type `narrow` on one + property. The new model is capability-only (Immutable A -> Mutable A, + then A = B required), so this becomes a compile error when the cleanup's + Stage D lands. */ +let open_source_setter_narrower = (o: {.."x": wide}): {@set "x": narrow} => + (o :> {@set "x": narrow}) + +/* EXPECTED TO FLIP (unsoundness, the strongest case). + + Today this whole block compiles, and `run_unrelated_setter()` returns + "hello" at declared type `int` when `plain_int_obj` is the plain JS + object {x: 1}. + + Mechanism: writability is a separate row member, so the assignment mints + "x#=": string => unit in o's open row from the right-hand side's type, + never relating it to the getter "x": int. The inferred demand is + {.."x": int, "x#=": string => unit} — but both members compile to the + same storage `o.x`, so the write invalidates the getter's type. + + New model: the assignment promotes the field to `Mutable int`, and + assigning a `string` is a unification error — the flip enforces the + getter/setter consistency invariant that is missing today. */ +let unrelated_setter_type = (o: {.."x": int}): int => { + o["x"] = "hello" + o["x"] +} + +@val external plain_int_obj: {.."x": int} = "plainIntObj" +let run_unrelated_setter = (): int => unrelated_setter_type(plain_int_obj) From bc00b9e12a19b1d4abc4c87e4e38f236aad2b151 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 27 Aug 2026 15:05:09 +0200 Subject: [PATCH 02/13] Remove obsolete object-field attribute forms (Stage 0) Only bare @set remains recognized on object-type fields. The undocumented forms - @get (bare or with the null/undefined/nullable payload) and @set({no_get: ...}) - lose their implementation entirely: they now behave like any other unrecognized attribute. A nullable getter type is written directly (null, undefined, nullable), and @set with a payload no longer marks a field settable, so writes to such fields fail with the standard missing-setter error. process_method_attributes_rev and its config parsing collapse into an 8-line bare-@set recognizer; the No_get branch and null/undefined type lifting disappear from process_getter_setter. Bs_syntaxerr's Unsupported_predicates variant is deleted with its only raisers, along with its ERROR_VARIANTS.md row and fixture. Removed features leave no test trace; mutable_obj_test.res's no_get case becomes bare @set with identical generated JS. Stage 0 of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- compiler/frontend/ast_attributes.ml | 54 +++---------------- compiler/frontend/ast_attributes.mli | 7 +-- compiler/frontend/ast_core_type_class_type.ml | 46 +++++----------- compiler/frontend/bs_syntaxerr.ml | 2 - compiler/frontend/bs_syntaxerr.mli | 1 - tests/ERROR_VARIANTS.md | 1 - .../bs_unsupported_predicates.res.expected | 8 --- .../fixtures/bs_unsupported_predicates.res | 1 - tests/tests/src/mutable_obj_test.res | 2 +- 9 files changed, 23 insertions(+), 99 deletions(-) delete mode 100644 tests/build_tests/super_errors/expected/bs_unsupported_predicates.res.expected delete mode 100644 tests/build_tests/super_errors/fixtures/bs_unsupported_predicates.res diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index 6ec6ad62ef..f586356369 100644 --- a/compiler/frontend/ast_attributes.ml +++ b/compiler/frontend/ast_attributes.ml @@ -24,55 +24,13 @@ type attr = Parsetree.attribute type t = attr list -type ('a, 'b) st = {get: 'a option; set: 'b option} -let process_method_attributes_rev (attrs : t) = - Ext_list.fold_left attrs - ({get = None; set = None}, []) - (fun (st, acc) (({txt; loc}, payload) as attr) -> - match txt with - | "get" (* @get{null; undefined}*) -> - let result = - Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) - (false, false) (fun (null, undefined) ({txt; loc}, opt_expr) -> - match txt with - | "null" -> - ( (match opt_expr with - | None -> true - | Some e -> Ast_payload.assert_bool_lit e), - undefined ) - | "undefined" -> - ( null, - match opt_expr with - | None -> true - | Some e -> Ast_payload.assert_bool_lit e ) - | "nullable" -> ( - match opt_expr with - | None -> (true, true) - | Some e -> - let v = Ast_payload.assert_bool_lit e in - (v, v)) - | _ -> Bs_syntaxerr.err loc Unsupported_predicates) - in - - ({st with get = Some result}, acc) - | "set" -> - let result = - Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) - `Get (fun _st ({txt; loc}, opt_expr) -> - (*FIXME*) - if txt = "no_get" then - match opt_expr with - | None -> `No_get - | Some e -> - if Ast_payload.assert_bool_lit e then `No_get else `Get - else Bs_syntaxerr.err loc Unsupported_predicates) - in - (* properties -- void - [@@set{only}] - *) - ({st with set = Some result}, acc) - | _ -> (st, attr :: acc)) +let process_object_field_attributes_rev (attrs : t) : bool * t = + Ext_list.fold_left attrs (false, []) + (fun (has_set, acc) (({txt}, payload) as attr) -> + match (txt, payload) with + | "set", Parsetree.PStr [] -> (true, acc) + | _ -> (has_set, attr :: acc)) type attr_kind = Nothing | Meth_callback of attr diff --git a/compiler/frontend/ast_attributes.mli b/compiler/frontend/ast_attributes.mli index 3fd96b5fa1..699b53b26d 100644 --- a/compiler/frontend/ast_attributes.mli +++ b/compiler/frontend/ast_attributes.mli @@ -25,9 +25,10 @@ type attr = Parsetree.attribute type t = attr list -type ('a, 'b) st = {get: 'a option; set: 'b option} - -val process_method_attributes_rev : t -> (bool * bool, [`Get | `No_get]) st * t +val process_object_field_attributes_rev : t -> bool * t +(** Recognizes the bare [@set] marker on an object-type field. Returns whether + the field is settable, plus the remaining attributes. Any other form is + left in place and ignored, like any unrecognized attribute. *) type attr_kind = Nothing | Meth_callback of attr diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index e8bfcb4cdd..70399a3c6b 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -21,40 +21,18 @@ * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ast_helper - let process_getter_setter ~not_getter_setter - ~(get : Parsetree.core_type -> _ -> Parsetree.attributes -> _) ~set loc name + ~(get : Parsetree.core_type -> _ -> Parsetree.attributes -> _) ~set name (attrs : Ast_attributes.t) (ty : Parsetree.core_type) (acc : _ list) = - match Ast_attributes.process_method_attributes_rev attrs with - | {get = None; set = None}, _ -> not_getter_setter ty :: acc - | st, pctf_attributes -> - let get_acc = - match st.set with - | Some `No_get -> acc - | None | Some `Get -> - let lift txt = Typ.constr ~loc {txt; loc} [ty] in - let null, undefined = - match st with - | {get = Some (null, undefined)} -> (null, undefined) - | {get = None} -> (false, false) - in - let ty = - match (null, undefined) with - | false, false -> ty - | true, false -> lift Ast_literal.Lid.js_null - | false, true -> lift Ast_literal.Lid.js_undefined - | true, true -> lift Ast_literal.Lid.js_null_undefined - in - get ty name pctf_attributes :: acc - in - if st.set = None then get_acc - else - set ty - ({name with txt = name.Asttypes.txt ^ Literals.setter_suffix} - : _ Asttypes.loc) - pctf_attributes - :: get_acc + match Ast_attributes.process_object_field_attributes_rev attrs with + | false, _ -> not_getter_setter ty :: acc + | true, pctf_attributes -> + set ty + ({name with txt = name.Asttypes.txt ^ Literals.setter_suffix} + : _ Asttypes.loc) + pctf_attributes + :: get ty name pctf_attributes + :: acc let default_typ_mapper = Ast_mapper.default_mapper.typ (* @@ -129,8 +107,8 @@ let typ_mapper (self : Ast_mapper.mapper) (ty : Parsetree.core_type) = in Parsetree.Otag (label, attrs, self.typ self core_type) in - process_getter_setter ~not_getter_setter ~get ~set loc label - ptyp_attrs core_type acc) + process_getter_setter ~not_getter_setter ~get ~set label ptyp_attrs + core_type acc) in {ty with ptyp_desc = Ptyp_object (new_methods, closed_flag)} | _ -> default_typ_mapper self ty diff --git a/compiler/frontend/bs_syntaxerr.ml b/compiler/frontend/bs_syntaxerr.ml index 062e38ff93..6f90d7fab1 100644 --- a/compiler/frontend/bs_syntaxerr.ml +++ b/compiler/frontend/bs_syntaxerr.ml @@ -25,7 +25,6 @@ type untagged_variant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray type error = - | Unsupported_predicates | Duplicated_bs_deriving | Conflict_attributes of string list | Expect_int_literal @@ -64,7 +63,6 @@ let pp_error fmt err = "Unsupported @return directive. Supported directives are `null_to_opt`, \ `null_undefined_to_opt` (or `nullable`), and `identity`." | Illegal_attribute -> "Illegal attributes" - | Unsupported_predicates -> "Unsupported predicates" | Duplicated_bs_deriving -> "Duplicate @deriving attribute; a type can only have one." | Conflict_attributes names -> diff --git a/compiler/frontend/bs_syntaxerr.mli b/compiler/frontend/bs_syntaxerr.mli index 3f457b0d5c..8819cbf67f 100644 --- a/compiler/frontend/bs_syntaxerr.mli +++ b/compiler/frontend/bs_syntaxerr.mli @@ -25,7 +25,6 @@ type untagged_variant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray type error = - | Unsupported_predicates | Duplicated_bs_deriving | Conflict_attributes of string list | Expect_int_literal diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index efca757da9..b509260a48 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -408,7 +408,6 @@ FFI / attribute / experimental-feature errors. Source: [bs_syntaxerr.ml:27](../c | Variant | Status | Fixture | Notes | |---|---|---|---| -| `Unsupported_predicates` | ✓ | `bs_unsupported_predicates.res` | `@get({weird: true})` on object type field. | | `Duplicated_bs_deriving` | ✓ | `duplicated_bs_deriving.res` | | | `Conflict_attributes` | ✓ | `bs_conflict_attributes.res` | | | `Expect_int_literal` | ✓ | `bs_expect_int_literal.res` | | diff --git a/tests/build_tests/super_errors/expected/bs_unsupported_predicates.res.expected b/tests/build_tests/super_errors/expected/bs_unsupported_predicates.res.expected deleted file mode 100644 index d1862f4974..0000000000 --- a/tests/build_tests/super_errors/expected/bs_unsupported_predicates.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/bs_unsupported_predicates.res:1:19-23 - - 1 │ type t = {..@get({weird: true}) "x": int} - 2 │ - - Unsupported predicates \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/bs_unsupported_predicates.res b/tests/build_tests/super_errors/fixtures/bs_unsupported_predicates.res deleted file mode 100644 index 6630acd60a..0000000000 --- a/tests/build_tests/super_errors/fixtures/bs_unsupported_predicates.res +++ /dev/null @@ -1 +0,0 @@ -type t = {..@get({weird: true}) "x": int} diff --git a/tests/tests/src/mutable_obj_test.res b/tests/tests/src/mutable_obj_test.res index 99ff9f3f80..8cec177ba8 100644 --- a/tests/tests/src/mutable_obj_test.res +++ b/tests/tests/src/mutable_obj_test.res @@ -5,7 +5,7 @@ let f = (x: u) => { x["height"] * 2 } -let f = (x: {@set({no_get: no_get}) "height": int}) => x["height"] = 3 +let f = (x: {@set "height": int}) => x["height"] = 3 type v = {@set "dec": int => {"x": int, "y": float}} From 0a69f68533bee263cbcd932ca560e9e7ac1cfcfb Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 27 Aug 2026 15:17:21 +0200 Subject: [PATCH 03/13] Delete dead class-system remnants around objects (Stage A) Mechanical deletions with no user-visible change, all provably dead since the class system's removal: - Tobject loses its class-abbreviation memo: the (Path.t * type_expr list) option ref second component was never constructed (every creation site built ref None; the surviving writers only propagated an existing Some). Its readers and propagation sites go with it: update_level's abbreviation branch, full_expand's Some-branch (the function is now repr . expand_head), the unify_fields name-propagation postlude, find_cltype_for_path and the class-abbreviation build_subtype arm, normalize_type_rec's name handling, and the nondep/subst/copy plumbing. - Texp_send drops its always-None third field and the single-constructor Tmeth_name wrapper (now a plain string). Typecore's degenerate match, the always-None obj_meths ref, and the dead Meths.fold branch of the undefined-method error handler are removed; the Meths module itself was then unused (Vars stands alone). - The frontend ## handling is deleted (unreachable from the parser); its one producer, @deriving(jsConverter)'s js_field, now builds Pexp_send directly. The #= arm's ##-peeling fallback and the bare-## error go too. - The outcometree class layer had no producers left: out_class_type, Octy_*, Ocsg_*, Osig_class, Osig_class_type, Otyp_class and their oprint and res_outcome_printer arms are deleted. - Stale class-era comments removed alongside. cmi magic Caml1999I025 -> Caml1999I026 (Tobject shape), cmt magic Caml1999T026 -> Caml1999T027 (Texp_send shape). Stage A of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- analysis/src/type_utils.ml | 8 +- compiler/ext/config.ml | 4 +- compiler/frontend/ast_derive_js_mapper.ml | 9 +- compiler/frontend/ast_exp_apply.ml | 58 +------ .../gentype/translate_type_expr_from_types.ml | 2 +- compiler/ml/btype.ml | 18 +-- compiler/ml/ctype.ml | 152 +++--------------- compiler/ml/ctype.mli | 1 - compiler/ml/includecore.ml | 4 +- compiler/ml/oprint.ml | 53 ------ compiler/ml/oprint.mli | 1 - compiler/ml/outcometree.ml | 21 --- compiler/ml/printtyp.ml | 72 +++------ compiler/ml/printtyped.ml | 5 +- compiler/ml/rec_check.ml | 4 +- compiler/ml/record_type_spread.ml | 2 +- compiler/ml/subst.ml | 10 +- compiler/ml/tast_iterator.ml | 4 +- compiler/ml/tast_mapper.ml | 3 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 32 ++-- compiler/ml/typedecl.ml | 8 +- compiler/ml/typedtree.ml | 4 +- compiler/ml/typedtree.mli | 4 +- compiler/ml/typedtree_iter.ml | 6 +- compiler/ml/types.ml | 5 +- compiler/ml/types.mli | 22 +-- compiler/ml/typetexp.ml | 2 +- compiler/syntax/src/res_outcome_printer.ml | 2 - 29 files changed, 105 insertions(+), 413 deletions(-) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index a9133f4293..1f4be403b5 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -34,7 +34,7 @@ let rec has_tvar (ty : Types.type_expr) : bool = List.exists (fun ({typ} : Types.arg) -> has_tvar typ) params || has_tvar ret | Ttuple tyl -> List.exists has_tvar tyl | Tconstr (_, tyl, _) -> List.exists has_tvar tyl - | Tobject (ty, _) -> has_tvar ty + | Tobject ty -> has_tvar ty | Tfield (_, _, ty1, ty2) -> has_tvar ty1 || has_tvar ty2 | Tnil -> false | Tlink ty -> has_tvar ty @@ -156,7 +156,7 @@ let instantiate_type ~type_params ~type_args (t : Types.type_expr) = loop ret ); } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tobject t -> {t with desc = Tobject (loop t)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} @@ -217,7 +217,7 @@ let instantiate_type2 ?(type_arg_context : type_arg_context option) loop ret ); } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tobject t -> {t with desc = Tobject (loop t)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} @@ -270,7 +270,7 @@ let rec extract_object_type ~state ~env ~package (t : Types.type_expr) = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> extract_object_type ~state ~env ~package t1 - | Tobject (t_obj, _) -> Some (env, t_obj) + | Tobject t_obj -> Some (env, t_obj) | Tconstr (path, type_args, _) -> ( match References.dig_constructor ~state ~env ~package path with | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) -> diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 365aa73197..b3ad9daca7 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I025" +let cmi_magic_number = "Caml1999I026" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T026" +and cmt_magic_number = "Caml1999T027" let load_path = ref ([] : string list) diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index 637b102fad..76a1be76dc 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -30,8 +30,13 @@ type tdcls = Parsetree.type_declaration list let app1 f arg1 = Exp.apply f [(Nolabel, arg1)] let app2 f arg1 arg2 = Exp.apply f [(Nolabel, arg1); (Nolabel, arg2)] -let js_field (o : Parsetree.expression) m = - app2 (Exp.ident {txt = Lident "##"; loc = o.pexp_loc}) o (Exp.ident m) +let js_field (o : Parsetree.expression) (m : Longident.t Asttypes.loc) = + let name = + match m.txt with + | Lident name -> name + | _ -> assert false + in + Exp.mk ~loc:m.loc (Ast_util.js_property m.loc o name) let handle_config (config : Parsetree.expression option) = match config with diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index 5775835fa0..c6fbeda749 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -70,7 +70,7 @@ let view_as_app (fn : exp) (s : string list) : app_pattern option = Some {op; loc = fn.pexp_loc; args = check_and_discard args} | _ -> None -let infix_ops = ["->"; "#="; "##"] +let infix_ops = ["->"; "#="] let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = match view_as_app e infix_ops with @@ -132,41 +132,6 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = pexp_loc = f.pexp_loc; }) | _ -> Exp.apply ~loc ~attrs:e.pexp_attributes f [(Nolabel, a)]) - | Some {op = "##"; loc; args = [obj; rest]} -> ( - (* - obj##property - - obj#(method a b ) - we should warn when we discard attributes - gpr#1063 foo##(bar##baz) we should rewrite (bar##baz) - first before pattern match. - currently the pattern match is written in a top down style. - Another corner case: f##(g a b [@bs]) - *) - match rest with - | { - pexp_desc = - ( Pexp_ident {txt = Lident name; _} - | Pexp_constant (Pconst_string (name, None)) ); - pexp_loc; - } - (* f##paint - TODO: this is not relevant: remove it later - *) -> - sane_property_name_check pexp_loc name; - {e with pexp_desc = Ast_util.js_property loc (self.expr self obj) name} - | _ -> Location.raise_errorf ~loc "invalid ## syntax") - (* we can not use [:=] for precedece cases - like {[i @@ x##length := 3 ]} - is parsed as {[ (i @@ x##length) := 3]} - since we allow user to create Js objects in OCaml, it can be of - ref type - {[ - let u = object (self) - val x = ref 3 - method setX x = self##x := 32 - method getX () = !self##x - end - ]} - *) | Some {op = "#="; loc; args = [obj; arg]} -> ( let gen_assignment obj name name_loc = sane_property_name_check name_loc name; @@ -180,29 +145,10 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = match obj.pexp_desc with | Pexp_send (obj, {txt = name; loc = name_loc}) -> gen_assignment obj name name_loc - | _ -> ( - match view_as_app obj ["##"] with - | Some - { - args = - [ - obj; - { - pexp_desc = - ( Pexp_ident {txt = Lident name} - | Pexp_constant (Pconst_string (name, None)) ); - pexp_loc = name_loc; - }; - ]; - } -> - gen_assignment obj name name_loc - | _ -> Location.raise_errorf ~loc "invalid #= assignment")) + | _ -> Location.raise_errorf ~loc "invalid #= assignment") | Some {op = "->"; loc} -> Location.raise_errorf ~loc "Invalid pipe syntax. The pipe symbol (->) can only be used as a binary \ operator." - | Some {op = "##"; loc} -> - Location.raise_errorf ~loc - "Js object ## expect syntax like obj##(paint (a,b)) " | Some {op} -> Location.raise_errorf "invalid %s syntax" op | None -> default_expr_mapper self e diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index 0e918375bf..db6061eae1 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -508,7 +508,7 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env in {dependencies = []; type_ = TypeVar type_name} | Tvar (Some s) -> {dependencies = []; type_ = TypeVar s} - | Tobject (t_obj, _) -> + | Tobject t_obj -> let rec get_field_types (texp : Types.type_expr) = match texp.desc with | Tfield (name, _, t1, t2) -> diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index ca64115aae..4359713094 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -195,7 +195,7 @@ let proxy ty = let ty0 = repr ty in match ty0.desc with | Tvariant row when not (static_row row) -> row_more row - | Tobject (ty, _) -> + | Tobject ty -> let rec proxy_obj ty = match ty.desc with | Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty @@ -210,7 +210,7 @@ let proxy ty = let row_of_type t = match (repr t).desc with - | Tobject (t, _) -> + | Tobject t -> let rec get_row t = let t = repr t in match t.desc with @@ -260,10 +260,7 @@ let iter_type_expr f ty = f ret | Ttuple l -> List.iter f l | Tconstr (_, l, _) -> List.iter f l - | Tobject (ty, {contents = Some (_, p)}) -> - f ty; - List.iter f p - | Tobject (ty, _) -> f ty + | Tobject ty -> f ty | Tvariant row -> iter_row f row; f (row_more row) @@ -352,10 +349,7 @@ let type_iterators = and it_do_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; match ty.desc with - | Tconstr (p, _, _) - | Tobject (_, {contents = Some (p, _)}) - | Tpackage (p, _, _) -> - it.it_path p + | Tconstr (p, _, _) | Tpackage (p, _, _) -> it.it_path p | Tvariant row -> may (fun (p, _) -> it.it_path p) (row_repr row).row_name | _ -> () and it_path _p = () in @@ -423,9 +417,7 @@ let rec copy_type_desc ?(keep_names = false) f = function Tarrow (List.map (fun arg -> {arg with typ = f arg.typ}) params, f ret) | Ttuple l -> Ttuple (List.map f l) | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) - | Tobject (ty, {contents = Some (p, tl)}) -> - Tobject (f ty, ref (Some (p, List.map f tl))) - | Tobject (ty, _) -> Tobject (f ty, ref None) + | Tobject ty -> Tobject (f ty) | Tvariant _ -> assert false (* too ambiguous *) | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 9d1746f476..41d1c74a7e 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -190,7 +190,7 @@ let newvar ?name () = newty2 !current_level (Tvar name) let newvar2 ?name level = newty2 level (Tvar name) let new_global_var ?name () = newty2 !global_level (Tvar name) -let newobj fields = newty (Tobject (fields, ref None)) +let newobj fields = newty (Tobject fields) let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) @@ -261,17 +261,12 @@ let is_datatype decl = (* Miscellaneous operations on object types *) (**********************************************) -(* Note: - We need to maintain some invariants: - * cty_self must be a Tobject - * ... -*) type fields = (string * Types.field_kind * Types.type_expr) list (**** Object field manipulation. ****) let object_fields ty = match (repr ty).desc with - | Tobject (fields, _) -> fields + | Tobject fields -> fields | _ -> assert false let flatten_fields (ty : Types.type_expr) : fields * _ = @@ -308,7 +303,7 @@ let associate_fields (fields1 : fields) (fields2 : fields) : _ * fields * fields let rec object_row ty = let ty = repr ty in match ty.desc with - | Tobject (t, _) -> object_row t + | Tobject t -> object_row t | Tfield (_, _, _, t) -> object_row t | _ -> ty @@ -380,11 +375,7 @@ let rec free_vars_rec real ty = free_variables := (ty, real) :: !free_variables with Not_found -> ()); List.iter (free_vars_rec true) tl - (* Do not count "virtual" free variables - | Tobject(ty, {contents = Some (_, p)}) -> - free_vars_rec false ty; List.iter (free_vars_rec true) p - *) - | Tobject (ty, _), _ -> free_vars_rec false ty + | Tobject ty, _ -> free_vars_rec false ty | Tfield (_, _, ty1, ty2), _ -> free_vars_rec true ty1; free_vars_rec false ty2 @@ -470,8 +461,6 @@ let closed_extension_constructor ext = (* Duplicate a type, preserving only type variables *) let duplicate_type ty = Subst.type_expr Subst.identity ty -(* Same, for class types *) - (*****************************) (* Type level manipulation *) (*****************************) @@ -589,10 +578,6 @@ let rec update_level env level expand ty = log_type ty; ty.desc <- Tpackage (p', nl, tl); update_level env level expand ty - | Tobject (_, ({contents = Some (p, _tl)} as nm)) - when level < get_level env p -> - set_name nm None; - update_level env level expand ty | Tvariant row -> let row = row_repr row in (match row.row_name with @@ -852,7 +837,7 @@ let rec copy ?env ?partial ?keep_names ty = | Fvar r -> dup_kind r; copy_type_desc copy desc) - | Tobject (ty1, _) when partial <> None -> Tobject (copy ty1, ref None) + | Tobject ty1 when partial <> None -> Tobject (copy ty1) | _ -> copy_type_desc ?keep_names copy desc); t @@ -1302,12 +1287,7 @@ let enforce_constraints env ty = (* Recursively expand the head of a type. Also expand #-types. *) -let full_expand env ty = - let ty = repr (expand_head env ty) in - match ty.desc with - | Tobject (fi, {contents = Some (_, v :: _)}) when is_Tvar (repr v) -> - newty2 ty.level (Tobject (fi, ref None)) - | _ -> ty +let full_expand env ty = repr (expand_head env ty) (* Check whether the abbreviation expands to a well-defined type. @@ -1810,8 +1790,7 @@ let rec mcomp type_pairs env t1 t2 = *) | Tpackage _, Tpackage _ -> () | Tvariant row1, Tvariant row2 -> mcomp_row type_pairs env row1 row2 - | Tobject (fi1, _), Tobject (fi2, _) -> - mcomp_fields type_pairs env fi1 fi2 + | Tobject fi1, Tobject fi2 -> mcomp_fields type_pairs env fi1 fi2 | Tfield _, Tfield _ -> (* Actually unused *) mcomp_fields type_pairs env t1' t2' @@ -2267,18 +2246,7 @@ and unify3 env t1 t1' t2 t2' = reify env t1'; reify env t2'; if !generate_equations then mcomp !env t1' t2' - | Tobject (fi1, nm1), Tobject (fi2, _) -> ( - unify_fields env fi1 fi2; - (* Type [t2'] may have been instantiated by [unify_fields] *) - (* XXX One should do some kind of unification... *) - match (repr t2').desc with - | Tobject (_, {contents = Some (_, va :: _)}) - when match (repr va).desc with - | Tvar _ | Tunivar _ | Tnil -> true - | _ -> false -> - () - | Tobject (_, nm2) -> set_name nm2 !nm1 - | _ -> ()) + | Tobject fi1, Tobject fi2 -> unify_fields env fi1 fi2 | Tvariant row1, Tvariant row2 -> ( if !umode = Expression then unify_row env row1 row2 else @@ -2697,7 +2665,7 @@ let filter_method env name priv ty = update_level env ty.level ty'; link_type ty ty'; filter_method_field env name priv ty1 - | Tobject (f, _) -> filter_method_field env name priv f + | Tobject f -> filter_method_field env name priv f | _ -> raise (Unify []) let moregen_occur env level ty = @@ -2776,7 +2744,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = with Not_found -> raise (Unify [])) | Tvariant row1, Tvariant row2 -> moregen_row inst_nongen type_pairs env row1 row2 - | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + | Tobject fi1, Tobject fi2 -> moregen_fields inst_nongen type_pairs env fi1 fi2 | Tfield _, Tfield _ -> (* Actually unused *) @@ -3053,7 +3021,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = with Not_found -> raise (Unify [])) | Tvariant row1, Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 - | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + | Tobject fi1, Tobject fi2 -> eqtype_fields rename type_pairs subst env fi1 fi2 | Tfield _, Tfield _ -> (* Actually unused *) @@ -3085,8 +3053,7 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = else (* Try expansion, needed when called from Includecore.type_manifest *) match expand_head_rigid env rest2 with - | {desc = Tobject (ty2, _)} -> - eqtype_fields rename type_pairs subst env ty1 ty2 + | {desc = Tobject ty2} -> eqtype_fields rename type_pairs subst env ty1 ty2 | _ -> let pairs, miss1, miss2 = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; @@ -3177,7 +3144,7 @@ let equal env rename tyl1 tyl2 = (* build_subtype: [visited] traces traversed object and variant types [loops] is a mapping from variables to variables, to reproduce - positive loops in a class type + positive loops [posi] true if the current variance is positive [level] number of expansions/enlargement allowed on this branch *) @@ -3212,17 +3179,6 @@ let rec lid_of_path ?(hash = "") = function that reaches here degrades gracefully instead of crashing the compiler. *) | Path.Papply _ as p -> Longident.Lident (hash ^ Path.name p) -let find_cltype_for_path env p = - let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in - let cl_abbr = Env.find_type cl_path env in - - match cl_abbr.type_manifest with - | Some ty -> ( - match (repr ty).desc with - | Tobject (_, {contents = Some (p', _)}) when Path.same p p' -> (cl_abbr, ty) - | _ -> raise Not_found) - | None -> assert false - let has_constr_row' env t = has_constr_row (expand_abbrev env t) let rec build_subtype env visited loops posi level t = @@ -3263,48 +3219,13 @@ let rec build_subtype env visited loops posi level t = let c = collect tlist' in if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) else (t, Unchanged) - | Tconstr (p, tl, abbrev) + | Tconstr (p, _, _) when level > 0 && generic_abbrev env p && safe_abbrev env t - && not (has_constr_row' env t) -> ( + && not (has_constr_row' env t) -> let t' = repr (expand_abbrev env t) in let level' = pred_expand level in - try - match t'.desc with - | Tobject _ when posi && not (opened_object t') -> - let cl_abbr, body = find_cltype_for_path env p in - let ty = - subst env !current_level Public abbrev None cl_abbr.type_params tl - body - in - let ty = repr ty in - let ty1, tl1 = - match ty.desc with - | Tobject (ty1, {contents = Some (p', tl1)}) when Path.same p p' -> - (ty1, tl1) - | _ -> raise Not_found - in - (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, - as this occurrence might break the occur check. - XXX not clear whether this correct anyway... *) - if List.exists (deep_occur ty) tl1 then raise Not_found; - ty.desc <- Tvar None; - let t'' = newvar () in - let loops = (ty, t'') :: loops in - (* May discard [visited] as level is going down *) - let ty1', c = - build_subtype env [t'] loops posi (pred_enlarge level') ty1 - in - assert (is_Tvar t''); - let nm = - if c > Equiv || deep_occur ty ty1' then None else Some (p, tl1) - in - t''.desc <- Tobject (ty1', ref nm); - (try unify_var env ty t with Unify _ -> assert false); - (t'', Changed) - | _ -> raise Not_found - with Not_found -> - let t'', c = build_subtype env visited loops posi level' t' in - if c > Unchanged then (t'', c) else (t, Unchanged)) + let t'', c = build_subtype env visited loops posi level' t' in + if c > Unchanged then (t'', c) else (t, Unchanged) | Tconstr (p, tl, _abbrev) -> ( if (* Must check recursion on constructors, since we do not always @@ -3371,7 +3292,7 @@ let rec build_subtype env visited loops posi level t = } in (newty (Tvariant row), Changed) - | Tobject (t1, _) -> + | Tobject t1 -> if memq_warn t visited || opened_object t1 then (t, Unchanged) else let level' = pred_enlarge level in @@ -3379,8 +3300,7 @@ let rec build_subtype env visited loops posi level t = t :: (if level' < level then [] else filter_visited visited) in let t1', c = build_subtype env visited loops posi level' t1 in - if c > Unchanged then (newty (Tobject (t1', ref None)), c) - else (t, Unchanged) + if c > Unchanged then (newty (Tobject t1'), c) else (t, Unchanged) | Tfield (s, _, t1, t2) (* Always present *) -> let t1', c1 = build_subtype env visited loops posi level t1 in let t2', c2 = build_subtype env visited loops posi level t2 in @@ -3756,11 +3676,11 @@ let rec subtype_rec env trace t1 t2 cstrs = | exception Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) - | Tobject (f1, _), Tobject (f2, _) + | Tobject f1, Tobject f2 when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> (* Same row variable implies same object. *) (trace, t1, t2, !univar_pairs, None) :: cstrs - | Tobject (f1, _), Tobject (f2, _) -> subtype_fields env trace f1 f2 cstrs + | Tobject f1, Tobject f2 -> subtype_fields env trace f1 f2 cstrs | Tvariant row1, Tvariant row2 -> ( try subtype_row env trace row1 row2 cstrs with Exit -> (trace, t1, t2, !univar_pairs, None) :: cstrs) @@ -3945,7 +3865,7 @@ let unalias ty = let row = row_repr row in let more = row.row_more in newty2 ty.level (Tvariant {row with row_more = newty2 more.level more.desc}) - | Tobject (ty, nm) -> newty2 ty.level (Tobject (unalias_object ty, nm)) + | Tobject ty -> newty2 ty.level (Tobject (unalias_object ty)) | _ -> newty2 ty.level ty.desc (* Check whether an abbreviation expands to itself. *) @@ -4055,23 +3975,7 @@ let rec normalize_type_rec env visited ty = in log_type ty; ty.desc <- Tvariant {row with row_fields = fields} - | Tobject (fi, nm) -> - (match !nm with - | None -> () - | Some (n, v :: l) -> ( - if deep_occur ty (newgenty (Ttuple l)) then - (* The abbreviation may be hiding something, so remove it *) - set_name nm None - else - let v' = repr v in - match v'.desc with - | Tvar _ | Tunivar _ -> - if v' != v then set_name nm (Some (n, v' :: l)) - | Tnil -> - log_type ty; - ty.desc <- Tconstr (n, l, ref Mnil) - | _ -> set_name nm None) - | _ -> fatal_error "Ctype.normalize_type_rec"); + | Tobject fi -> let fi = repr fi in if fi.level < lowest_level then () else @@ -4131,15 +4035,7 @@ let rec nondep_type_rec env id ty = let p' = normalize_package_path env p in if Path.isfree id p' then raise Not_found; Tpackage (p', nl, List.map (nondep_type_rec env id) tl) - | Tobject (t1, name) -> - Tobject - ( nondep_type_rec env id t1, - ref - (match !name with - | None -> None - | Some (p, tl) -> - if Path.isfree id p then None - else Some (p, List.map (nondep_type_rec env id) tl)) ) + | Tobject t1 -> Tobject (nondep_type_rec env id t1) | Tvariant row -> ( let row = row_repr row in let more = repr row.row_more in diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 025c162e30..7b609a9c5e 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -113,7 +113,6 @@ val associate_fields : * (string * field_kind * type_expr) list * (string * field_kind * type_expr) list val opened_object : type_expr -> bool -val find_cltype_for_path : Env.t -> Path.t -> type_declaration * type_expr val lid_of_path : ?hash:string -> Path.t -> Longident.t val sort_row_fields : (label * row_field) list -> (label * row_field) list diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 619c30a2bf..af630bf08a 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -125,8 +125,8 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = && let tl1, tl2 = List.split !to_equal in Ctype.equal env true tl1 tl2 - | Tobject (fi1, _), Tobject (fi2, _) - when is_absrow env (snd (Ctype.flatten_fields fi2)) -> + | Tobject fi1, Tobject fi2 when is_absrow env (snd (Ctype.flatten_fields fi2)) + -> let fields2, rest2 = Ctype.flatten_fields fi2 in Ctype.equal env true (ty1 :: params1) (rest2 :: params2) && diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml index f72f6dd76f..674d48333a 100644 --- a/compiler/ml/oprint.ml +++ b/compiler/ml/oprint.ml @@ -270,10 +270,6 @@ and print_out_type_2 ppf = function | ty -> print_simple_out_type ppf ty and print_simple_out_type ppf = function - | Otyp_class (ng, id, tyl) -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl - (if ng then "_" else "") - print_ident id | Otyp_constr (id, tyl) -> pp_open_box ppf 0; print_typargs ppf tyl; @@ -392,45 +388,6 @@ let type_parameter ppf (ty, (co, cn)) = (if not cn then "+" else if not co then "-" else "") (if ty = "_" then ty else "'" ^ ty) -let print_out_class_params ppf = function - | [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list type_parameter (fun ppf -> fprintf ppf ", ")) - tyl - -let rec print_out_class_type ppf = function - | Octy_constr (id, tyl) -> - let pr_tyl ppf = function - | [] -> () - | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_signature (self_ty, csil) -> - let pr_param ppf = function - | Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty - | None -> () - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil - -and print_out_class_sig_item ppf = function - | Ocsg_constraint (ty1, ty2) -> - fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2 - | Ocsg_method (name, priv, virt, ty) -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") - (if virt then "virtual " else "") - name !out_type ty - | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s :@ %a@]" - (if mut then "mutable " else "") - (if vr then "virtual " else "") - name !out_type ty - -let out_class_type = ref print_out_class_type - (* Signature *) let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") @@ -500,16 +457,6 @@ and print_out_signature ppf = function fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items and print_out_sig_item ppf = function - | Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") - print_out_class_params params name !out_class_type clt - | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") - print_out_class_params params name !out_class_type clt | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) diff --git a/compiler/ml/oprint.mli b/compiler/ml/oprint.mli index e449527e26..d37d206c7d 100644 --- a/compiler/ml/oprint.mli +++ b/compiler/ml/oprint.mli @@ -20,7 +20,6 @@ val out_ident : (formatter -> string -> unit) ref val out_value : (formatter -> out_value -> unit) ref val out_type : (formatter -> out_type -> unit) ref -val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref val out_sig_item : (formatter -> out_sig_item -> unit) ref val out_signature : (formatter -> out_sig_item list -> unit) ref diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml index aa5d3e4a9e..4b83893b55 100644 --- a/compiler/ml/outcometree.ml +++ b/compiler/ml/outcometree.ml @@ -54,7 +54,6 @@ type out_type = | Otyp_open | Otyp_alias of out_type * string | Otyp_arrow of (Asttypes.Noloc.arg_label * out_type) list * out_type - | Otyp_class of bool * out_ident * out_type list | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type | Otyp_object of (string * out_type) list * bool option @@ -72,14 +71,6 @@ and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_typ of out_type -type out_class_type = - | Octy_constr of out_ident * out_type list - | Octy_signature of out_type option * out_class_sig_item list -and out_class_sig_item = - | Ocsg_constraint of out_type * out_type - | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * bool * out_type - type out_module_type = | Omty_abstract | Omty_functor of string * out_module_type option * out_module_type @@ -87,18 +78,6 @@ type out_module_type = | Omty_signature of out_sig_item list | Omty_alias of out_ident and out_sig_item = - | Osig_class of - bool - * string - * (string * (bool * bool)) list - * out_class_type - * out_rec_status - | Osig_class_type of - bool - * string - * (string * (bool * bool)) list - * out_class_type - * out_rec_status | Osig_typext of out_extension_constructor * out_ext_status | Osig_modtype of string * out_module_type | Osig_module of string * out_module_type * out_rec_status diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index c5a280f143..a481784ea0 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -172,12 +172,7 @@ and raw_type_desc ppf = function | Tconstr (p, tl, abbrev) -> fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl (raw_list path) (list_of_memo !abbrev) - | Tobject (t, nm) -> - fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t (fun ppf -> - match !nm with - | None -> fprintf ppf " None" - | Some (p, tl) -> - fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tobject t -> fprintf ppf "@[Tobject@,%a@]" raw_type t | Tfield (f, k, t1, t2) -> fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f (safe_kind_repr [] k) raw_type t1 raw_type t2 @@ -524,18 +519,15 @@ let rec mark_loops_rec visited ty = | Some (_p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> iter_row (mark_loops_rec visited) row) - | Tobject (fi, nm) -> + | Tobject fi -> if List.memq px !visited_objects then add_alias px else ( if opened_object ty then visited_objects := px :: !visited_objects; - match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) - fields - | Some (_, l) -> List.iter (mark_loops_rec visited) (List.tl l)) + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) + fields) | Tfield (_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 @@ -691,8 +683,8 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = if all_present then None else Some (List.map fst present) in Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)) - | Tobject (fi, nm) -> tree_of_typobject ?printing_context sch fi !nm - | Tnil | Tfield _ -> tree_of_typobject ?printing_context sch ty None + | Tobject fi -> tree_of_typobject ?printing_context sch fi + | Tnil | Tfield _ -> tree_of_typobject ?printing_context sch ty | Tsubst ty -> tree_of_typexp ?printing_context sch ty | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" | Tpoly (ty, []) -> tree_of_typexp ?printing_context sch ty @@ -740,33 +732,23 @@ and tree_of_row_field ?printing_context sch (l, f) = and tree_of_typlist ?printing_context sch tyl = List.map ((tree_of_typexp ?printing_context) sch) tyl -and tree_of_typobject ?printing_context sch fi nm = - match nm with - | None -> - let pr_fields fi = - let fields, rest = flatten_fields fi in - let present_fields = - List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpresent -> (n, t) :: l - | _ -> l) - fields [] - in - let sorted_fields = - List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields - in - tree_of_typfields ?printing_context sch rest sorted_fields - in - let fields, rest = pr_fields fi in - Otyp_object (fields, rest) - | Some (p, ty :: tyl) -> - let non_gen = is_non_gen sch (repr ty) in - let args = tree_of_typlist ?printing_context sch tyl in - let p', s = best_type_path p in - assert (s = Id); - Otyp_class (non_gen, tree_of_path p', args) - | _ -> fatal_error "Printtyp.tree_of_typobject" +and tree_of_typobject ?printing_context sch fi = + let fields, rest = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpresent -> (n, t) :: l + | _ -> l) + fields [] + in + let sorted_fields = + List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields + in + let fields, rest = + tree_of_typfields ?printing_context sch rest sorted_fields + in + Otyp_object (fields, rest) and is_non_gen sch ty = sch && is_Tvar ty && ty.level <> generic_level @@ -1067,8 +1049,6 @@ let tree_of_value_description id decl = let value_description id ppf decl = !Oprint.out_sig_item ppf (tree_of_value_description id decl) -(* Print a class type *) - (* Print a module type *) let wrap_env fenv ftree arg = diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index fa21e1b911..23fc083854 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -364,10 +364,9 @@ and expression i ppf x = line i ppf "Texp_for_await_of \"%a\"\n" fmt_ident s; expression i ppf e1; expression i ppf e2 - | Texp_send (e, Tmeth_name s, eo) -> + | Texp_send (e, s) -> line i ppf "Texp_send \"%s\"\n" s; - expression i ppf e; - option i expression ppf eo + expression i ppf e | Texp_letmodule (s, _, me, e) -> line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; module_expr i ppf me; diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index ef9fdd5e70..1c1f7a6811 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -296,9 +296,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = Use.(join (discard (expression env e1)) (expression env e2)) | Texp_while (e1, e2) -> Use.(join (inspect (expression env e1)) (discard (expression env e2))) - | Texp_send (e1, _, eo) -> - Use.( - join (inspect (expression env e1)) (inspect (option expression env eo))) + | Texp_send (e1, _) -> Use.inspect (expression env e1) | Texp_field (e, _, _) -> Use.(inspect (expression env e)) | Texp_letexception (_, e) -> expression env e | Texp_assert e -> Use.inspect (expression env e) diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 18f921c966..9da527bbe3 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -33,7 +33,7 @@ let substitute_types ~type_map (t : Types.type_expr) = loop ret ); } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tobject t -> {t with desc = Tobject (loop t)} | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 46ebe3c720..12fd6da706 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -179,15 +179,7 @@ let rec typexp s ty = (!ctype_apply_env_empty params body args).desc) | Tpackage (p, n, tl) -> Tpackage (modtype_path s p, n, List.map (typexp s) tl) - | Tobject (t1, name) -> - Tobject - ( typexp s t1, - ref - (match !name with - | None -> None - | Some (p, tl) -> - if to_subst_by_type_function s p then None - else Some (type_path s p, List.map (typexp s) tl)) ) + | Tobject t1 -> Tobject (typexp s t1) | Tvariant row -> ( let row = row_repr row in let more = repr row.row_more in diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index fcc25510d7..36d869e85a 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -199,9 +199,7 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_for_await_of (_, _, exp1, exp2) -> sub.expr sub exp1; sub.expr sub exp2 - | Texp_send (exp, _, expo) -> - sub.expr sub exp; - Option.iter (sub.expr sub) expo + | Texp_send (exp, _) -> sub.expr sub exp | Texp_letmodule (_, _, mexpr, exp) -> sub.module_expr sub mexpr; sub.expr sub exp diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index cbf0c45b5f..0d5155cedc 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -253,8 +253,7 @@ let expr sub x = Texp_for_of (id, p, sub.expr sub exp1, sub.expr sub exp2) | Texp_for_await_of (id, p, exp1, exp2) -> Texp_for_await_of (id, p, sub.expr sub exp1, sub.expr sub exp2) - | Texp_send (exp, meth, expo) -> - Texp_send (sub.expr sub exp, meth, opt (sub.expr sub) expo) + | Texp_send (exp, meth) -> Texp_send (sub.expr sub exp, meth) | Texp_letmodule (id, s, mexpr, exp) -> Texp_letmodule (id, s, sub.module_expr sub mexpr, sub.expr sub exp) | Texp_letexception (cd, exp) -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index c034ec5dc1..ca76197e77 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1217,7 +1217,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lfor_of (param, transl_exp iterable, transl_exp body) | Texp_for_await_of (param, _, iterable, body) -> Lfor_await_of (param, transl_exp iterable, transl_exp body) - | Texp_send (expr, Tmeth_name nm, _) -> + | Texp_send (expr, nm) -> let obj = transl_exp expr in Lsend (nm, obj, e.exp_loc) | Texp_letmodule (id, _loc, modl, body) -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 8c01ed30f1..b0e7e24f2c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3302,27 +3302,21 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } | Pexp_send (e, {txt = met}) -> ( let obj = type_exp ~context:None env e in - let obj_meths = ref None in try - let meth, exp, typ = - match obj.exp_desc with - | _ -> (Tmeth_name met, None, filter_method env met Public obj.exp_type) - in + let typ = filter_method env met Public obj.exp_type in let typ = match repr typ with | {desc = Tpoly (ty, [])} -> instance env ty - | {desc = Tpoly (ty, tl); level = _} -> snd (instance_poly false tl ty) + | {desc = Tpoly (ty, tl)} -> snd (instance_poly false tl ty) | {desc = Tvar _} as ty -> let ty' = newvar () in unify env (instance_def ty) (newty (Tpoly (ty', []))); - (* if not !Clflags.nolabels then - Location.prerr_warning loc (Warnings.Unknown_method met); *) ty' | _ -> assert false in rue { - exp_desc = Texp_send (obj, meth, exp); + exp_desc = Texp_send (obj, met); exp_loc = loc; exp_extra = []; exp_type = typ; @@ -3331,18 +3325,14 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } with Unify _ -> let valid_methods = - match !obj_meths with - | Some meths -> - Some (Meths.fold (fun meth _meth_ty li -> meth :: li) !meths []) - | None -> ( - match (expand_head env obj.exp_type).desc with - | Tobject (fields, _) -> - let fields, _ = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if meth_kind = Fpresent then meth :: li else li - in - Some (List.fold_left collect_fields [] fields) - | _ -> None) + match (expand_head env obj.exp_type).desc with + | Tobject fields -> + let fields, _ = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if meth_kind = Fpresent then meth :: li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None in raise (Error diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 25c193eaa0..ef267b6864 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -185,7 +185,7 @@ let set_fixed_row env loc p decl = let row = Btype.row_repr row in tm.desc <- Tvariant {row with row_fixed = true}; if Btype.static_row row then Btype.newgenty Tnil else row.row_more - | Tobject (ty, _) -> snd (Ctype.flatten_fields ty) + | Tobject ty -> snd (Ctype.flatten_fields ty) | _ -> raise (Error (loc, Bad_fixed_type "is not an object or variant")) in if not (Btype.is_Tvar rv) then @@ -1077,7 +1077,7 @@ let compute_variance env visited vari ty = compute_variance_rec v2 ty) tl decl.type_variance with Not_found -> List.iter (compute_variance_rec may_inv) tl) - | Tobject (ty, _) -> compute_same ty + | Tobject ty -> compute_same ty | Tfield (_, _, ty1, ty2) -> compute_same ty1; compute_same ty2 @@ -2077,7 +2077,7 @@ let explain_unbound_gen ppf tv tl typ kwd pr = let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) - Btype.newgenty (Tobject (tv, ref None)) + Btype.newgenty (Tobject tv) in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" kwd @@ -2093,7 +2093,7 @@ let explain_unbound_single ppf tv ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in match (Ctype.repr ty).desc with - | Tobject (fi, _) -> + | Tobject fi -> let tl, rv = Ctype.flatten_fields fi in if rv == tv then trivial ty else diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 852e94fb6d..d2a0a4d4b5 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -123,7 +123,7 @@ and expression_desc = * expression * direction_flag * expression - | Texp_send of expression * meth * expression option + | Texp_send of expression * string | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression @@ -135,8 +135,6 @@ and expression_desc = | Texp_for_of of Ident.t * Parsetree.pattern * expression * expression | Texp_for_await_of of Ident.t * Parsetree.pattern * expression * expression -and meth = Tmeth_name of string - and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} and function_param = { diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 1541215a39..af91174207 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -224,7 +224,7 @@ and expression_desc = * expression * direction_flag * expression - | Texp_send of expression * meth * expression option + | Texp_send of expression * string | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression @@ -236,8 +236,6 @@ and expression_desc = | Texp_for_of of Ident.t * Parsetree.pattern * expression * expression | Texp_for_await_of of Ident.t * Parsetree.pattern * expression * expression -and meth = Tmeth_name of string - and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} and function_param = { diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index 378891ce04..bf6da3f8d7 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -286,11 +286,7 @@ end = struct | Texp_for_await_of (_id, _, exp1, exp2) -> iter_expression exp1; iter_expression exp2 - | Texp_send (exp, _meth, expo) -> ( - iter_expression exp; - match expo with - | None -> () - | Some exp -> iter_expression exp) + | Texp_send (exp, _meth) -> iter_expression exp | Texp_letmodule (_id, _, mexpr, exp) -> iter_module_expr mexpr; iter_expression exp diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 7a544622f1..018d8fbc2a 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -28,7 +28,7 @@ and type_desc = | Tarrow of arg list * type_expr | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref - | Tobject of type_expr * (Path.t * type_expr list) option ref + | Tobject of type_expr | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr @@ -74,8 +74,7 @@ module Ordered_string = struct type t = string let compare (x : t) y = compare x y end -module Meths = Map.Make (Ordered_string) -module Vars = Meths +module Vars = Map.Make (Ordered_string) (* Value descriptions *) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index df6a8bae27..dc5e571925 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -72,23 +72,10 @@ and type_desc = | Tconstr of Path.t * type_expr list * abbrev_memo ref (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] The last parameter keep tracks of known expansions, see [abbrev_memo]. *) - | Tobject of type_expr * (Path.t * type_expr list) option ref - (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + | Tobject of type_expr + (** [Tobject `f1:t1;...;fn: tn'] ==> [{"f1": t1, ..., "fn": tn}] f1, fn are represented as a linked list of types using Tfield and Tnil - constructors. - - [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. - where A.ct is the type of some class. - - There are also special cases for so-called "class-types", cf. [Typeclass]: - - [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), - Some(`A.#ct`, [rv;t1;...;tn])] - ==> [(t1, ..., tn) #A.ct] - [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct] - - where [rv] is the hidden row variable. - *) + constructors, terminated by a row variable when the row is open. *) | Tfield of string * field_kind * type_expr * type_expr (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) | Tnil (** [Tnil] ==> [<...; >] *) @@ -186,9 +173,6 @@ module Type_ops : sig val hash : t -> int end -(* Maps of methods and instance variables *) - -module Meths : Map.S with type key = string module Vars : Map.S with type key = string (* Value descriptions *) diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 9dcfd66938..b14afe6dc9 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -596,7 +596,7 @@ and transl_fields env policy o fields = in let t = expand_head env cty.ctyp_type in match (t, nm) with - | {desc = Tobject ({desc = (Tfield _ | Tnil) as tf}, _)}, _ -> + | {desc = Tobject {desc = (Tfield _ | Tnil) as tf}}, _ -> if opened_object t then raise (Error (sty.ptyp_loc, env, Opened_object nm)); let rec iter_add = function diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index a35eac3686..adfe76936b 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -142,7 +142,6 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) = | Otyp_var (ng, s) -> Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] | Otyp_object (fields, rest) -> print_object_fields fields rest - | Otyp_class _ -> Doc.nil | Otyp_attribute (typ, attribute) -> Doc.group (Doc.concat @@ -611,7 +610,6 @@ let print_external_decl_attrs_doc (decl : External_ffi_types.external_decl) let rec print_out_sig_item_doc ?(print_name_as_is = false) (out_sig_item : Outcometree.out_sig_item) = match out_sig_item with - | Osig_class _ | Osig_class_type _ -> Doc.nil | Osig_ellipsis -> Doc.dotdotdot | Osig_value value_decl -> let ffi_attrs, keyword, prim_name = From e37380187ca508bdd76521a5f81319548db8a7f8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 27 Aug 2026 15:24:27 +0200 Subject: [PATCH 04/13] Share object property access between Lambda and Lam (Stage B) Property get/set becomes a pair of primitives present identically in both IRs: Pjs_object_get and Pjs_object_set, replacing the Lambda-only Lsend node and the Lam-only Pjs_unsafe_downgrade primitive (whose name described a Js.t coercion removed years ago). Setter recognition moves from lam_convert to translation: translcore matches the applied setter member directly and emits Pjs_object_set with the property name; bare sends emit Pjs_object_get. The "#=" suffix recognition and name surgery disappear from lam_convert, whose two Lsend cases are deleted; the suffix channel now ends at translation and is removed entirely by the mutability stage (#8584 Stage D). Also swept while here: the CamlinternalOO/%sendcache method-table comment archaeology in lam_compile, the Lsend design notes in bs_builtin_ppx.mli, commented-out Lsend lines in lam/lam_analysis, and the editor tooling's Js_OO.unsafe_downgrade heuristic (self-documented as unreachable since compiler 9.0). Generated JavaScript is byte-identical across the test corpus (no .mjs diffs). Lam.t serialization changes shape; cmjs are per-compiler-version artifacts rebuilt on compiler update. Stage B of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- analysis/src/references.ml | 15 ------- compiler/core/lam.ml | 1 - compiler/core/lam.mli | 1 - compiler/core/lam_analysis.ml | 5 +-- compiler/core/lam_compile.ml | 60 +++----------------------- compiler/core/lam_compile_primitive.ml | 2 +- compiler/core/lam_convert.ml | 24 ++--------- compiler/core/lam_primitive.ml | 11 +++-- compiler/core/lam_primitive.mli | 3 +- compiler/core/lam_print.ml | 4 +- compiler/frontend/bs_builtin_ppx.mli | 32 -------------- compiler/ml/lambda.ml | 8 ++-- compiler/ml/lambda.mli | 3 +- compiler/ml/printlambda.ml | 3 +- compiler/ml/translcore.ml | 17 +++++++- 15 files changed, 46 insertions(+), 143 deletions(-) diff --git a/analysis/src/references.ml b/analysis/src/references.ml index 2f3946bddc..6f54eaf609 100644 --- a/analysis/src/references.ml +++ b/analysis/src/references.ml @@ -78,21 +78,6 @@ let get_loc_item ~full ~pos ~debug = heuristic for: [Props, x], give loc of `x`"; if debug then Printf.printf "n1:%s n2:%s\n" (name_of li1) (name_of li2); Some li2 - | [ - ({loc_type = Typed (_, _, LocalReference _)} as li1); - ({ - loc_type = Typed (_, _, GlobalReference ("Js_OO", ["unsafe_downgrade"], _)); - } as li2); - li3; - ] - (* For older compiler 9.0 or earlier *) - when li1.loc = li2.loc && li2.loc = li3.loc -> - (* Not currently testable on 9.1.4 *) - log 6 - "heuristic for JSX and compiler combined:\n\ - ~x becomes Js_OO.unsafe_downgrade(Props)#x\n\ - heuristic for: [Props, unsafe_downgrade, x], give loc of `x`"; - Some li3 | [ ({loc_type = Typed (_, _, LocalReference (_, Value))} as li1); ({loc_type = Typed (_, _, Definition (_, Value))} as li2); diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index b3a1be65bd..de5dd2c89d 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -107,7 +107,6 @@ module Types = struct | Lfor_of of ident * t * t | Lfor_await_of of ident * t * t | Lassign of ident * t - (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) end include Types diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 4e5584e6e8..82dbd1e0d6 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -79,7 +79,6 @@ and t = private | Lfor_await_of of ident * t * t | Lassign of ident * t -(* | Lsend of Lambda.meth_kind * t * t * t list * Location.t *) (* | Levent of t * Lambda.lambda_event [Levent] in the branch hurt pattern match, we should use record for trivial debugger info diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 0154033c64..b1f10dc12a 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -93,7 +93,8 @@ let rec no_side_effects (lam : Lam.t) : bool = (* A tagged template invokes its tag at runtime, so it always has side effects. *) | Ptagged_template | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod - | Pupdate_mod | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method + | Pupdate_mod | Pjs_object_get _ | Pjs_object_set _ | Pdebugger + | Pjs_fn_method (* Await promise *) | Pawait (* TODO *) @@ -123,7 +124,6 @@ let rec no_side_effects (lam : Lam.t) : bool = | Lfor _ -> false | Lfor_of _ | Lfor_await_of _ -> false | Lassign _ -> false (* actually it depends ... *) - (* | Lsend _ -> false *) | Lapply { ap_func = Lprim {primitive = Pfield (_, Fld_module {name = "from_fun"})}; @@ -186,7 +186,6 @@ let rec size (lam : Lam.t) = | Lfor_of _ | Lfor_await_of _ -> really_big () | Lassign (_, v) -> 1 + size v (* This is side effectful, be careful *) - (* | Lsend _ -> really_big () *) with Too_big_to_inline -> 1000 and size_constant x = diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index aa8d5116d6..41a238f07f 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1405,50 +1405,6 @@ let compile output_prefix = Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall new_return_type}) - (* Note that in [Texp_apply] for [%sendcache] the cache might not be used - see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch - [Texp_apply] when [public_send ], args are simply dropped - - reference - [js_of_ocaml] - 1. GETPUBMET - 2. GETDYNMET - 3. GETMETHOD - [ocaml] - Lsend (bytegen.ml) - For the object layout refer to [camlinternalOO/create_object] - {[ - let create_object table = - (* XXX Appel de [obj_block] *) - let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in - (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.methods); - Obj.obj (set_id obj) - - let create_object_opt obj_0 table = - if (Obj.magic obj_0 : bool) then obj_0 else begin - (* XXX Appel de [obj_block] *) - let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in - (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.methods); - Obj.obj (set_id obj) - end - ]} - it's a block with tag [248], the first field is [table.methods] which is an array - {[ - type table = - { mutable size: int; - mutable methods: closure array; - mutable methods_by_name: meths; - mutable methods_by_label: labs; - mutable previous_states: - (meths * labs * (label * item) list * vars * - label list * string list) list; - mutable hidden_meths: (label * item) list; - mutable vars: vars; - mutable initializers: (obj -> unit) list } - ]} - *) and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) (f_branch : Lam.t) (lambda_cxt : Lam_compile_context.t) = match @@ -1765,11 +1721,8 @@ let compile output_prefix = check the arity of fn before wrapping it we need mark something that such eta-conversion can not be simplified in some cases *) - | { - primitive = Pjs_unsafe_downgrade {name = property; setter = false}; - args = [obj]; - } -> ( - (* getter {[ x #. height ]} *) + | {primitive = Pjs_object_get property; args = [obj]} -> ( + (* property read: obj["height"] *) match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} obj with @@ -1785,11 +1738,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation blocks ret) - | { - primitive = Pjs_unsafe_downgrade {name = property; setter = true}; - args = [obj; setter_val]; - } -> ( - (* setter {[ x ## method_call ]} *) + | {primitive = Pjs_object_set property; args = [obj; setter_val]} -> ( + (* property write: obj["height"] = v *) let need_value_no_return_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in @@ -1812,7 +1762,7 @@ let compile output_prefix = | Some (obj_code, obj) -> cont obj_block arg_block (Some obj_code) (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit))) - | {primitive = Pjs_unsafe_downgrade _; args} -> assert false + | {primitive = Pjs_object_get _ | Pjs_object_set _; args} -> assert false | {primitive = Pjs_fn_method; args = args_lambda} -> ( match args_lambda with | [Lfunction {params; body; attr = {return_unit; async}; loc}] -> diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 3b986dd4ae..45bf8fad93 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -176,7 +176,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args) | Ptypeof -> E.typeof (Ext_list.singleton_exn args) - | Pjs_unsafe_downgrade _ | Pdebugger | Pjs_fn_method -> + | Pjs_object_get _ | Pjs_object_set _ | Pdebugger | Pjs_fn_method -> assert false (* already handled by {!Lam_compile} *) | Pstringadd -> ( match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 34084ecc9a..54fd637865 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -316,6 +316,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = ~args loc | Pjs_object_create labels -> prim ~primitive:(Pjs_object_create labels) ~args loc + | Pjs_object_get name -> prim ~primitive:(Pjs_object_get name) ~args loc + | Pjs_object_set name -> prim ~primitive:(Pjs_object_set name) ~args loc | Praw_js_code info -> prim ~primitive:(Praw_js_code info) ~args loc | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc @@ -333,22 +335,6 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : match lam with | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) - | Lapply {ap_func = Lsend (name, obj, loc); ap_args} - when Ext_string.ends_with name Literals.setter_suffix -> - let obj = convert_aux obj in - let args = obj :: Ext_list.map ap_args convert_aux in - let property = - String.sub name 0 (String.length name - Literals.setter_suffix_len) - in - prim - ~primitive:(Pjs_unsafe_downgrade {name = property; setter = true}) - ~args loc - | Lsend (name, obj, loc) -> - let obj = convert_aux obj in - let args = [obj] in - let setter = Ext_string.ends_with name Literals.setter_suffix in - let _ = assert (not setter) in - prim ~primitive:(Pjs_unsafe_downgrade {name; setter}) ~args loc | Lapply { ap_func = fn; @@ -483,10 +469,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : match f with | Lapply {ap_loc} -> Some ap_loc | Lfunction {loc} -> Some loc - | Lprim (_, _, loc) - | Lswitch (_, _, loc) - | Lstringswitch (_, _, _, loc) - | Lsend (_, _, loc) -> + | Lprim (_, _, loc) | Lswitch (_, _, loc) | Lstringswitch (_, _, _, loc) + -> Some loc | _ -> None in diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index a4bf24dd73..4eacac5654 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -145,7 +145,8 @@ type t = | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger - | Pjs_unsafe_downgrade of {name: string; setter: bool} + | Pjs_object_get of string + | Pjs_object_set of string | Pinit_mod | Pupdate_mod | Praw_js_code of Js_raw_info.t @@ -288,9 +289,13 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Poffsetref i1 -> i0 = i1 | _ -> false) - | Pjs_unsafe_downgrade {name; setter} -> ( + | Pjs_object_get name -> ( match rhs with - | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter + | Pjs_object_get rhs_name -> name = rhs_name + | _ -> false) + | Pjs_object_set name -> ( + match rhs with + | Pjs_object_set rhs_name -> name = rhs_name | _ -> false) | Praw_js_code _ -> false (* TOO lazy, here comparison is only approximation*) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index e504f5527d..9d537cf4b1 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -139,7 +139,8 @@ type t = | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger - | Pjs_unsafe_downgrade of {name: string; setter: bool} + | Pjs_object_get of string + | Pjs_object_set of string | Pinit_mod | Pupdate_mod | Praw_js_code of Js_raw_info.t diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 72e03a3e82..b459bedd8a 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -56,8 +56,8 @@ let primitive ppf (prim : Lam_primitive.t) = | Pjs_runtime_apply -> fprintf ppf "#runtime_apply" (* Debug-only dump, exercised solely under -drawlambda/-dlambda. *) | Ptagged_template -> fprintf ppf "#tagged_template" [@coverage off] - | Pjs_unsafe_downgrade {name; setter} -> - if setter then fprintf ppf "##%s#=" name else fprintf ppf "##%s" name + | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name + | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name | Pfn_arity -> fprintf ppf "fn.length" | Pjs_fn_method -> fprintf ppf "js_fn_method" | Pdebugger -> fprintf ppf "debugger" diff --git a/compiler/frontend/bs_builtin_ppx.mli b/compiler/frontend/bs_builtin_ppx.mli index 7533a1f5c6..f3f0da5dd2 100644 --- a/compiler/frontend/bs_builtin_ppx.mli +++ b/compiler/frontend/bs_builtin_ppx.mli @@ -23,35 +23,3 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val mapper : Ast_mapper.mapper - -(* object - for setter : we can push more into [Lsend] and enclose it with a unit type - - for getter : - - (* Invariant: we expect the typechecker & lambda emitter - will not do agressive inlining - Worst things could happen - {[ - let x = y## case 3 in - x 2 - ]} - in normal case, it should be compiled into Lambda - {[ - let x = Lsend(y,case, [3]) in - Lapp(x,2) - ]} - - worst: - {[ Lsend(y, case, [3,2]) - ]} - for setter(include case setter), this could - be prevented by type system, for getter. - - solution: we can prevent this by rewrite into - {[ - Fn.run1 (!x# case) v -]} - *) - - *) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 944e08d29b..e53cdceaca 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -198,6 +198,8 @@ type primitive = transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params + | Pjs_object_get of string + | Pjs_object_set of string (* Exceptions *) | Praise of raise_kind (* object operations *) @@ -383,7 +385,6 @@ type lambda = | Lfor_of of Ident.t * lambda * lambda | Lfor_await_of of Ident.t * lambda * lambda | Lassign of Ident.t * lambda - | Lsend of string * lambda * Location.t and lfunction = { params: Ident.t list; @@ -503,7 +504,6 @@ let make_key e = | Lbreak -> Lbreak | Lcontinue -> Lcontinue | Lassign (x, e) -> Lassign (x, tr_rec env e) - | Lsend (m, e1, _loc) -> Lsend (m, tr_rec env e1, Location.none) | Lletrec _ | Lfunction _ | Lfor _ | Lfor_of _ | Lfor_await_of _ | Lwhile _ -> raise_notrace Not_simple @@ -586,7 +586,6 @@ let iter f = function f e1; f e2 | Lassign (_, e) -> f e - | Lsend (_k, obj, _) -> f obj module Ident_set = Set.Make (Ident) @@ -610,7 +609,7 @@ let free_ids get l = | Lassign (id, _e) -> fv := Ident_set.add id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak | Lcontinue - | Lwhile _ | Lsend _ -> + | Lwhile _ -> () in free l; @@ -721,7 +720,6 @@ let subst_lambda s lam = | Lfor_of (v, e1, e2) -> Lfor_of (v, subst e1, subst e2) | Lfor_await_of (v, e1, e2) -> Lfor_await_of (v, subst e1, subst e2) | Lassign (id, e) -> Lassign (id, subst e) - | Lsend (k, obj, loc) -> Lsend (k, subst obj, loc) and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) and subst_strcase (key, case) = (key, subst case) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index c893e21d0c..8e0134747c 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -164,6 +164,8 @@ type primitive = transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params + | Pjs_object_get of string + | Pjs_object_set of string (* Exceptions *) | Praise of raise_kind (* object primitives *) @@ -355,7 +357,6 @@ type lambda = | Lfor_of of Ident.t * lambda * lambda | Lfor_await_of of Ident.t * lambda * lambda | Lassign of Ident.t * lambda - | Lsend of string * lambda * Location.t and lfunction = { params: Ident.t list; diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 620713b542..112e1ebf36 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -123,6 +123,8 @@ let primitive ppf = function fprintf ppf "record_rest(%s)" (String.concat ", " excluded) | Pjs_call {prim_name} -> fprintf ppf "js_call[%s]" prim_name | Pjs_object_create _ -> fprintf ppf "js_obj_create" + | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name + | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Pobjcomp Ceq -> fprintf ppf "==" | Pobjcomp Cneq -> fprintf ppf "!=" @@ -410,7 +412,6 @@ let rec lam ppf = function iterable lam body | Lassign (id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (name, obj, _) -> fprintf ppf "@[<2>(send%s@ %a@ )@]" name lam obj and sequence ppf = function | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index ca76197e77..b1e462db07 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1069,6 +1069,17 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) | Ploc _, _ -> assert false | _, _ -> wrap (Lprim (prim, argl, e.exp_loc))))) + | Texp_apply + { + funct = {exp_desc = Texp_send (obj, name)}; + args = [(Nolabel, Some value)]; + } + when Ext_string.ends_with name Literals.setter_suffix -> + let property = + String.sub name 0 (String.length name - Literals.setter_suffix_len) + in + Lprim + (Pjs_object_set property, [transl_exp obj; transl_exp value], e.exp_loc) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct @@ -1218,8 +1229,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_for_await_of (param, _, iterable, body) -> Lfor_await_of (param, transl_exp iterable, transl_exp body) | Texp_send (expr, nm) -> - let obj = transl_exp expr in - Lsend (nm, obj, e.exp_loc) + (* A setter member only ever occurs applied (recognized in the + [Texp_apply] case); a bare occurrence cannot be compiled. *) + assert (not (Ext_string.ends_with nm Literals.setter_suffix)); + Lprim (Pjs_object_get nm, [transl_exp expr], e.exp_loc) | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in Llet (Strict, Pgenval, id, defining_expr, transl_exp body) From 6e06ec0cbe3ef6f9359d345f30798fbbbeb6f539 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 27 Aug 2026 16:06:03 +0200 Subject: [PATCH 05/13] Type and translate object literals directly (Stage C) {"a": 1} becomes a first-class node end to end: the parser produces Pexp_object_literal, typecore types it directly as a closed object row (fields Tpoly-wrapped exactly as written object types are, duplicates unified against the first occurrence), and translation emits Pjs_object_create. Generated JavaScript is byte-identical across the test corpus. This deletes the literal's former detour through the frontend: the %obj extension expansion, record_as_js_object, and the synthetic letmodule-wrapped external (local_external_obj, pval_prim_of_labels, from_labels) are gone. The jsConverter deriver builds the node directly. The %obj shape survives only as the frozen-parsetree encoding: the v0 bridge maps Pexp_object_literal to the reserved %obj-extension-over-record form and back, covered by a new fixture in tests/syntax_tests/data/ast-mapping/ (the res_parser -test-ast-conversion roundtrip infra), and AGENTS.md now documents that infra next to the parsetree0 rule. Printer, parens (bracket-access and JSX positions), comments table, parsetree viewer, AST debugger, depend, pprintast, printast, completion, and semantic highlighting all handle the node; object-key highlighting and the object-vs-record error hint (whose rewrite suggestion still matched the old %obj encoding) are preserved, the latter now also firing in array-item context. Two error snapshots update to more accurate context phrasing ("this function argument is expecting"). ast magics ResImpl01301/ResIntf01301 -> ResImpl01302/ResIntf01302. Stage C of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- AGENTS.md | 4 +- analysis/src/completion_front_end.ml | 4 +- analysis/src/semantic_tokens.ml | 9 +++ analysis/src/utils.ml | 1 + compiler/ext/config.ml | 4 +- compiler/frontend/ast_core_type.ml | 16 ---- compiler/frontend/ast_core_type.mli | 7 -- compiler/frontend/ast_derive_js_mapper.ml | 27 ++----- compiler/frontend/ast_exp_extension.ml | 16 +--- compiler/frontend/ast_external_mk.ml | 23 ------ compiler/frontend/ast_external_mk.mli | 11 --- compiler/frontend/ast_external_process.ml | 11 --- compiler/frontend/ast_external_process.mli | 7 -- compiler/frontend/ast_util.ml | 18 ----- compiler/frontend/ast_util.mli | 6 -- compiler/ml/ast_helper.ml | 1 + compiler/ml/ast_helper.mli | 3 + compiler/ml/ast_iterator.ml | 6 ++ compiler/ml/ast_mapper.ml | 3 + compiler/ml/ast_mapper_from0.ml | 26 +++++++ compiler/ml/ast_mapper_to0.ml | 14 ++++ compiler/ml/depend.ml | 1 + compiler/ml/error_message_utils.ml | 73 ++++++++++--------- compiler/ml/parsetree.ml | 2 + compiler/ml/pprintast.ml | 5 ++ compiler/ml/printast.ml | 7 ++ compiler/ml/printtyped.ml | 7 ++ compiler/ml/rec_check.ml | 8 +- compiler/ml/tast_iterator.ml | 2 + compiler/ml/tast_mapper.ml | 2 + compiler/ml/translcore.ml | 14 ++++ compiler/ml/typecore.ml | 39 +++++++++- compiler/ml/typedtree.ml | 1 + compiler/ml/typedtree.mli | 1 + compiler/ml/typedtree_iter.ml | 2 + compiler/syntax/src/res_ast_debugger.ml | 10 +++ compiler/syntax/src/res_comments_table.ml | 8 +- compiler/syntax/src/res_core.ml | 13 +++- compiler/syntax/src/res_parens.ml | 24 +++--- compiler/syntax/src/res_parsetree_viewer.ml | 8 +- compiler/syntax/src/res_printer.ml | 61 ++++++++-------- .../deadcode/expected/deadcode.txt | 7 +- .../src/expected/CompletionObjects.res.txt | 1 - .../expected/dict_helper.res.expected | 2 +- ...l_passed_when_record_expected.res.expected | 4 +- .../data/ast-mapping/ObjectLiterals.res | 9 +++ .../expected/ObjectLiterals.res.txt | 9 +++ .../expressions/expected/object.res.txt | 2 +- .../expressions/expected/bsObject.res.txt | 11 ++- .../expected/objectTypeSpreading.res.txt | 11 +-- 50 files changed, 304 insertions(+), 257 deletions(-) create mode 100644 tests/syntax_tests/data/ast-mapping/ObjectLiterals.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/ObjectLiterals.res.txt diff --git a/AGENTS.md b/AGENTS.md index 6678816e53..a4b5ceffa0 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -34,7 +34,9 @@ The Makefile’s targets build on each other in this order: - **We are NOT bound by OCaml compatibility** - The ReScript compiler originated as a fork of the OCaml compiler, but we maintain our own AST and can make breaking changes. Focus on what's best for ReScript's JavaScript compilation target. -- **Never modify `parsetree0.ml`** - Existing PPX (parser extensions) rely on this frozen v0 version. When changing `parsetree.ml`, always update the mapping modules `ast_mapper_from0.ml` and `ast_mapper_to0.ml` to maintain PPX compatibility while allowing the main parsetree to evolve +- **Never modify `parsetree0.ml`** - Existing PPX (parser extensions) rely on this frozen v0 version. When changing `parsetree.ml`, always update the mapping modules `ast_mapper_from0.ml` and `ast_mapper_to0.ml` to maintain PPX compatibility while allowing the main parsetree to evolve. **Test the bridge with the existing infra** — do not build new harnesses for this: + - Add a source fixture exercising the new syntax to `tests/syntax_tests/data/ast-mapping/`. Every file there is run through `res_parser -test-ast-conversion` (which round-trips the parsetree through the frozen v0 AST before printing) as part of `make test-syntax`; the printed output must match the snapshot in its `expected/` directory. + - For exact-identity invariants (locations, attributes) or the v0 wire shape itself, add cases to `tests/ounit_tests/ounit_ast_mapper0_tests.ml`, which tests `ast_mapper_to0`/`ast_mapper_from0` directly. - **Missing test coverage** - Always add tests for syntax, lambda, and end-to-end behavior diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index a0ea27e0ac..eb8d5b39a4 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -1230,8 +1230,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file if expr.pexp_loc |> Loc.has_pos ~pos:pos_no_white && !result = None then ( set_found (); match expr.pexp_desc with - | Pexp_extension ({txt = "obj"}, PStr [str_item]) -> - Ast_iterator.default_iterator.structure_item iterator str_item + | Pexp_object_literal fields -> + List.iter (fun (_, e) -> iterator.expr iterator e) fields | Pexp_extension ({txt}, _) -> set_result (CextensionNode txt) | Pexp_constant _ -> set_result Cnone | Pexp_ident lid -> diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 279212ee32..38d06ec143 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -358,6 +358,15 @@ let command ~debug ~emitter ~source ~kind_file = Printf.printf "Binary operator %s %s\n" op (Loc.to_string loc); emitter |> emit_from_loc ~loc ~type_:Operator; Ast_iterator.default_iterator.expr iterator e + | Pexp_object_literal fields -> + fields + |> List.iter (fun ((s : string Asttypes.loc), _) -> + if not (Utils.is_first_char_uppercase s.txt) then + emitter + |> emit_record_label + ~label:{Asttypes.txt = Longident.Lident s.txt; loc = s.loc} + ~debug); + Ast_iterator.default_iterator.expr iterator e | Pexp_record (cases, _) -> Ext_list.filter_map cases (fun {lid} -> match lid.txt with diff --git a/analysis/src/utils.ml b/analysis/src/utils.ml index 31444f880e..54eecc8d7b 100644 --- a/analysis/src/utils.ml +++ b/analysis/src/utils.ml @@ -108,6 +108,7 @@ let identify_pexp pexp = | Pexp_constraint _ -> "Pexp_constraint" | Pexp_coerce _ -> "Pexp_coerce" | Pexp_send _ -> "Pexp_send" + | Pexp_object_literal _ -> "Pexp_object_literal" | Pexp_letmodule _ -> "Pexp_letmodule" | Pexp_letexception _ -> "Pexp_letexception" | Pexp_assert _ -> "Pexp_assert" diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index b3ad9daca7..d6f7f9f94b 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I026" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01301" +and ast_impl_magic_number = "ResImpl01302" -and ast_intf_magic_number = "ResIntf01301" +and ast_intf_magic_number = "ResIntf01302" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index 32ed7ca837..2e99e12ea7 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -84,22 +84,6 @@ let is_user_option (ty : t) = ]} will be recognized as a invalid program *) -let from_labels ~loc arity labels : t = - let tyvars = - Ext_list.init arity (fun i -> Typ.var ~loc ("a" ^ string_of_int i)) - in - let result_type = - Typ.object_ ~loc - (Ext_list.map2 labels tyvars (fun x y -> Parsetree.Otag (x, [], y))) - Closed - in - let args = - Ext_list.map2 labels tyvars (fun label tyvar -> - {Parsetree.attrs = []; lbl = Asttypes.Labelled label; typ = tyvar}) - in - match args with - | [] -> result_type - | _ -> Typ.arrow ~loc args result_type let make_obj ~loc xs = Typ.object_ ~loc xs Closed diff --git a/compiler/frontend/ast_core_type.mli b/compiler/frontend/ast_core_type.mli index 5e352a7f24..46ca298652 100644 --- a/compiler/frontend/ast_core_type.mli +++ b/compiler/frontend/ast_core_type.mli @@ -30,13 +30,6 @@ val is_unit : t -> bool val is_builtin_rank0_type : string -> bool -val from_labels : loc:Location.t -> int -> string Asttypes.loc list -> t -(** return a function type - [from_labels ~loc tyvars labels] - example output: - {[x:'a0 -> y:'a1 -> < x :'a0 ;y :'a1 >]} -*) - val make_obj : loc:Location.t -> Parsetree.object_field list -> t val is_user_option : t -> bool diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index 76a1be76dc..b8ccadda9e 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -192,27 +192,12 @@ let init () = | Ptype_record label_declarations -> let exp = coerce_result_to_new_type - (Exp.extension - ( {Asttypes.loc; txt = "obj"}, - PStr - [ - Str.eval - (Exp.record - (Ext_list.map label_declarations - (fun {pld_name = {loc; txt}} -> - let label = - { - Asttypes.loc; - txt = Longident.Lident txt; - } - in - { - Parsetree.lid = label; - x = Exp.field exp_param label; - opt = false; - })) - None); - ] )) + (Exp.object_literal ~loc + (Ext_list.map label_declarations + (fun {pld_name = {loc; txt}} -> + ( {Asttypes.loc; txt}, + Exp.field exp_param + {Asttypes.loc; txt = Longident.Lident txt} )))) in let to_js = to_js_body exp in let obj_exp = diff --git a/compiler/frontend/ast_exp_extension.ml b/compiler/frontend/ast_exp_extension.ml index 8b45cadc1d..c26a63fa55 100644 --- a/compiler/frontend/ast_exp_extension.ml +++ b/compiler/frontend/ast_exp_extension.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Ast_helper -let handle_extension e (self : Ast_mapper.mapper) +let handle_extension e (_self : Ast_mapper.mapper) (({txt; loc}, payload) : Parsetree.extension) = match txt with | "todo" -> @@ -63,20 +63,6 @@ let handle_extension e (self : Ast_mapper.mapper) (Ast_comb.to_regexp_type loc) | "debugger" -> {e with pexp_desc = Ast_exp_handle_external.handle_debugger loc payload} - | "obj" -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval (({pexp_desc = Pexp_record (label_exprs, None)} as e), _); - }; - ] -> - { - e with - pexp_desc = Ast_util.record_as_js_object e.pexp_loc self label_exprs; - } - | _ -> Location.raise_errorf ~loc "Expect a record expression here") | _ -> e (* For an unknown extension, we don't really need to process further*) (* Exp.extension ~loc ~attrs:e.pexp_attributes ( diff --git a/compiler/frontend/ast_external_mk.ml b/compiler/frontend/ast_external_mk.ml index 4703eb5e0a..0c27344d18 100644 --- a/compiler/frontend/ast_external_mk.ml +++ b/compiler/frontend/ast_external_mk.ml @@ -44,29 +44,6 @@ let local_external_apply loc ?(pval_attributes = []) {txt = Ldot (Lident local_module_name, local_fun_name); loc}) (Ext_list.map args (fun x -> (Asttypes.Nolabel, x))) ) -let local_external_obj loc ?(pval_attributes = []) - ~(pval_prim : Parsetree.primitive_repr) ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") args : - Parsetree.expression_desc = - Pexp_letmodule - ( {txt = local_module_name; loc}, - Ast_helper.Mod.structure ~loc - [ - Ast_helper.Str.primitive ~loc - { - pval_name = {txt = local_fun_name; loc}; - pval_type; - pval_loc = loc; - pval_prim = Some pval_prim; - pval_attributes; - }; - ], - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc - {txt = Ldot (Lident local_module_name, local_fun_name); loc}) - (Ext_list.map args (fun (l, a) -> - (Asttypes.Labelled {txt = l; loc = Location.none}, a))) ) - let inline_const (c : External_ffi_types.inline_const) : Parsetree.primitive_repr = Prim_inline_const c diff --git a/compiler/frontend/ast_external_mk.mli b/compiler/frontend/ast_external_mk.mli index a6d2856443..86625df063 100644 --- a/compiler/frontend/ast_external_mk.mli +++ b/compiler/frontend/ast_external_mk.mli @@ -42,17 +42,6 @@ val local_external_apply : ]} *) -val local_external_obj : - Location.t -> - ?pval_attributes:Parsetree.attributes -> - pval_prim:Parsetree.primitive_repr -> - pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> - (string * Parsetree.expression) list -> - (* [ (label, exp )]*) - Parsetree.expression_desc - val inline_string : string -> string option -> Parsetree.primitive_repr val inline_bool : bool -> Parsetree.primitive_repr diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index 76e3549e55..a3400da883 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -1015,17 +1015,6 @@ let handle_attributes_as_prim (pval_loc : Location.t) (typ : Ast_core_type.t) no_inline_cross_module; } -let pval_prim_of_labels (labels : string Asttypes.loc list) = - let arg_kinds = - Ext_list.fold_right labels - ([] : External_arg_spec.obj_params) - (fun p arg_kinds -> - let obj_arg_label = External_arg_spec.obj_label p.txt in - {obj_arg_type = Nothing; obj_arg_label} :: arg_kinds) - in - Parsetree.Prim_ffi - {name = ""; spec = External_ffi_types.ffi_obj_create arg_kinds} - let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) (ends_with_unit : bool) = let arg_kinds = diff --git a/compiler/frontend/ast_external_process.mli b/compiler/frontend/ast_external_process.mli index 7b1a2d64c2..33a1a5a5fd 100644 --- a/compiler/frontend/ast_external_process.mli +++ b/compiler/frontend/ast_external_process.mli @@ -40,12 +40,5 @@ val handle_attributes_as_prim : return value is of [pval_type, pval_prim, new_attrs] *) -val pval_prim_of_labels : string Asttypes.loc list -> Parsetree.primitive_repr -(** [pval_prim_of_labels labels] - return [pval_prim] for FFI, it is specialized for - external object which is used in - {[ [%obj { x = 2; y = 1} ] ]} -*) - val pval_prim_of_option_labels : (bool * string Asttypes.loc) list -> bool -> Parsetree.primitive_repr diff --git a/compiler/frontend/ast_util.ml b/compiler/frontend/ast_util.ml index f32cc50d8b..ccb94d5c03 100644 --- a/compiler/frontend/ast_util.ml +++ b/compiler/frontend/ast_util.ml @@ -24,21 +24,3 @@ let js_property loc obj (name : string) = Parsetree.Pexp_send (obj, {loc; txt = name}) - -let record_as_js_object loc (self : Ast_mapper.mapper) - (label_exprs : Parsetree.expression Parsetree.record_element list) : - Parsetree.expression_desc = - let labels, args, arity = - Ext_list.fold_right label_exprs ([], [], 0) - (fun {lid = {txt; loc}; x = e} (labels, args, i) -> - match txt with - | Lident x -> - ( {Asttypes.loc; txt = x} :: labels, - (x, self.expr self e) :: args, - i + 1 ) - | Ldot _ -> Location.raise_errorf ~loc "invalid js label ") - in - Ast_external_mk.local_external_obj loc - ~pval_prim:(Ast_external_process.pval_prim_of_labels labels) - ~pval_type:(Ast_core_type.from_labels ~loc arity labels) - args diff --git a/compiler/frontend/ast_util.mli b/compiler/frontend/ast_util.mli index 8ffdbf0c0e..a3583d485a 100644 --- a/compiler/frontend/ast_util.mli +++ b/compiler/frontend/ast_util.mli @@ -28,11 +28,5 @@ - convert a uncuried application to normal *) -val record_as_js_object : - Location.t -> - Ast_mapper.mapper -> - Parsetree.expression Parsetree.record_element list -> - Parsetree.expression_desc - val js_property : Location.t -> Parsetree.expression -> string -> Parsetree.expression_desc diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index e49daf5fe6..6381ae626f 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -188,6 +188,7 @@ module Exp = struct let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c)) let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let object_literal ?loc ?attrs a = mk ?loc ?attrs (Pexp_object_literal a) let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 4926fad13a..9a7a3385df 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -206,6 +206,9 @@ module Exp : sig val constraint_ : ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + + val object_literal : + ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression val letmodule : ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression -> expression val letexception : diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 710a4bcedb..180664308b 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -361,6 +361,12 @@ module E = struct sub.expr sub e; sub.typ sub t | Pexp_send (e, _s) -> sub.expr sub e + | Pexp_object_literal fields -> + List.iter + (fun (s, e) -> + iter_loc sub s; + sub.expr sub e) + fields | Pexp_letmodule (s, me, e) -> iter_loc sub s; sub.module_expr sub me; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 88c2c6043b..400db4ce76 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -349,6 +349,9 @@ module E = struct | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_literal fields -> + object_literal ~loc ~attrs + (List.map (fun (s, e) -> (map_loc sub s, sub.expr sub e)) fields) | Pexp_letmodule (s, me, e) -> letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) (sub.expr sub e) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 3531d9124a..fed41b7e58 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -764,6 +764,32 @@ module E = struct | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_extension + ( {txt = "obj"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_record (rows, None)}, []); + }; + ] ) + when List.for_all + (fun ((lid : Longident.t Location.loc), _) -> + match lid.txt with + | Longident.Lident _ -> true + | _ -> false) + rows -> + (* Decode the reserved v0 %obj encoding of object literals. *) + object_literal ~loc ~attrs + (List.map + (fun ((lid : Longident.t Location.loc), e) -> + let name = + match lid.txt with + | Longident.Lident name -> name + | _ -> assert false + in + ({txt = name; loc = lid.loc}, sub.expr sub e)) + rows) | Pexp_new _ -> failwith "Pexp_new is no longer present in ReScript" | Pexp_setinstvar _ -> failwith "Pexp_setinstvar is no longer present in ReScript" diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 733c05f57f..70830bee41 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -593,6 +593,20 @@ module E = struct | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_literal fields -> + (* v0 encoding: the reserved %obj extension over a record expression. *) + let rows = + List.map + (fun (s, e) -> + let s = map_loc sub s in + ({s with txt = Longident.Lident s.txt}, sub.expr sub e)) + fields + in + extension ~loc ~attrs + ( {txt = "obj"; loc}, + PStr + [Ast_helper0.Str.eval ~loc (Ast_helper0.Exp.record ~loc rows None)] + ) | Pexp_letmodule (s, me, e) -> letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) (sub.expr sub e) diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index cf826136c7..d9a0f31be9 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -280,6 +280,7 @@ let rec add_expr bv exp = add_expr bv e1; add_type bv ty2 | Pexp_send (e, _m) -> add_expr bv e + | Pexp_object_literal fields -> List.iter (fun (_, e) -> add_expr bv e) fields | Pexp_letmodule (id, m, e) -> let b = add_module_binding bv m in add_expr (String_map.add id.txt b bv) e diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 7499169397..00bdbe4b06 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -233,6 +233,40 @@ let extract_string_constant text = Some s | _ -> None +let print_object_vs_record_hint ppf ~loc = + fprintf ppf + "@,\ + @,\ + You're passing a @{ReScript object@} where a @{record@} is \ + expected. Objects are written with quoted keys, and records with unquoted \ + keys."; + let suggested_rewrite = + Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> + match exp.Parsetree.pexp_desc with + | Pexp_object_literal fields -> + Some + (Ast_helper.Exp.record ~loc:exp.pexp_loc + (List.map + (fun ((s : string Asttypes.loc), e) -> + { + Parsetree.lid = + {Asttypes.txt = Longident.Lident s.txt; loc = s.loc}; + x = e; + opt = false; + }) + fields) + None) + | _ -> None) + in + fprintf ppf + "@,@,Possible solutions: @,- Rewrite the object to a record%s@{%s@}@," + (match suggested_rewrite with + | Some _ -> ", like: " + | None -> "") + (match suggested_rewrite with + | Some rewrite -> rewrite + | None -> "") + let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf (bottom_aliases : (Types.type_expr * Types.type_expr) option) trace type_clash_context = @@ -416,6 +450,11 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf `yourValue->Option.getOr(someDefaultValue)`" | Some ComparisonOperator, _ -> fprintf ppf "\n\n You can only compare things of the same type." + | Some ArrayValue, Some ({desc = Tobject _}, ({Types.desc = Tconstr _} as t1)) + when is_record_type ~extract_concrete_typedecl ~env t1 -> + (* The array-item mismatch is an object-vs-record confusion; give the + specific hint rather than the generic array advice. *) + print_object_vs_record_hint ppf ~loc | Some ArrayValue, _ -> fprintf ppf "\n\n\ @@ -465,39 +504,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @{ignore@} via @{expression->ignore@}\n\n" | _, Some ({desc = Tobject _}, ({Types.desc = Tconstr _} as t1)) when is_record_type ~extract_concrete_typedecl ~env t1 -> - fprintf ppf - "@,\ - @,\ - You're passing a @{ReScript object@} where a @{record@} is \ - expected. Objects are written with quoted keys, and records with \ - unquoted keys."; - - let suggested_rewrite = - Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> - match exp.Parsetree.pexp_desc with - | Pexp_extension - ( {txt = "obj"}, - PStr - [ - { - pstr_desc = - Pstr_eval (({pexp_desc = Pexp_record _} as record), _); - }; - ] ) -> - Some record - | _ -> None) - in - fprintf ppf - "@,\ - @,\ - Possible solutions: @,\ - - Rewrite the object to a record%s@{%s@}@," - (match suggested_rewrite with - | Some _ -> ", like: " - | None -> "") - (match suggested_rewrite with - | Some rewrite -> rewrite - | None -> "") + print_object_vs_record_hint ppf ~loc | _, Some ({Types.desc = Tconstr (p1, _, _)}, _) when Path.same p1 Predef.path_promise -> fprintf ppf "\n\n - Did you mean to await this promise before using it?\n" diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 9385901bbe..585cd77f8d 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -303,6 +303,8 @@ and expression_desc = (* (E :> T) (None, T) *) | Pexp_send of expression * label loc (* E # m *) + | Pexp_object_literal of (label loc * expression) list + (* {"a": 1, "b": true} *) | Pexp_letmodule of string loc * module_expr * expression (* let module M = ME in E *) | Pexp_letexception of extension_constructor * expression diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index cb93e02b0d..ff1538f2a2 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -770,6 +770,11 @@ and expression2 ctxt f x = | Pexp_field (e, li) -> pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | Pexp_object_literal fields -> + pp f "@[{%a}@]" + (list ~sep:",@ " (fun f ((s : string Asttypes.loc), e) -> + pp f "@[\"%s\":@ %a@]" s.txt (expression ctxt) e)) + fields | _ -> simple_expr ctxt f x and simple_expr ctxt f x = diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 246b311589..f763d41b49 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -244,6 +244,13 @@ and expression i ppf x = let i = i + 1 in match x.pexp_desc with | Pexp_ident li -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li + | Pexp_object_literal fields -> + line i ppf "Pexp_object_literal\n"; + List.iter + (fun ((s : string Asttypes.loc), e) -> + line i ppf "field \"%s\"\n" s.txt; + expression i ppf e) + fields | Pexp_constant c -> line i ppf "Pexp_constant %a\n" fmt_constant c | Pexp_let (rf, l, e) -> line i ppf "Pexp_let %a\n" fmt_rec_flag rf; diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 23fc083854..c6cb73f21e 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -367,6 +367,13 @@ and expression i ppf x = | Texp_send (e, s) -> line i ppf "Texp_send \"%s\"\n" s; expression i ppf e + | Texp_object_literal fields -> + line i ppf "Texp_object_literal\n"; + List.iter + (fun ((s : string Asttypes.loc), e) -> + line i ppf "field \"%s\"\n" s.txt; + expression i ppf e) + fields | Texp_letmodule (s, _, me, e) -> line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; module_expr i ppf me; diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 1c1f7a6811..70aefd8884 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -201,9 +201,9 @@ let rec classify_expression : Typedtree.expression -> sd = classify_expression e | Texp_ident _ | Texp_for _ | Texp_for_of _ | Texp_for_await_of _ | Texp_constant _ | Texp_tuple _ | Texp_array _ | Texp_construct _ - | Texp_variant _ | Texp_record _ | Texp_setfield _ | Texp_while _ - | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ | Texp_break - | Texp_continue -> + | Texp_variant _ | Texp_record _ | Texp_object_literal _ | Texp_setfield _ + | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ + | Texp_break | Texp_continue -> Static | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> Static @@ -297,6 +297,8 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Texp_while (e1, e2) -> Use.(join (inspect (expression env e1)) (discard (expression env e2))) | Texp_send (e1, _) -> Use.inspect (expression env e1) + | Texp_object_literal fields -> + Use.inspect (list (fun env (_, e) -> expression env e) env fields) | Texp_field (e, _, _) -> Use.(inspect (expression env e)) | Texp_letexception (_, e) -> expression env e | Texp_assert e -> Use.inspect (expression env e) diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 36d869e85a..11c014bb58 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -200,6 +200,8 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.expr sub exp1; sub.expr sub exp2 | Texp_send (exp, _) -> sub.expr sub exp + | Texp_object_literal fields -> + List.iter (fun (_, e) -> sub.expr sub e) fields | Texp_letmodule (_, _, mexpr, exp) -> sub.module_expr sub mexpr; sub.expr sub exp diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 0d5155cedc..31b79f7cef 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -254,6 +254,8 @@ let expr sub x = | Texp_for_await_of (id, p, exp1, exp2) -> Texp_for_await_of (id, p, sub.expr sub exp1, sub.expr sub exp2) | Texp_send (exp, meth) -> Texp_send (sub.expr sub exp, meth) + | Texp_object_literal fields -> + Texp_object_literal (List.map (fun (s, e) -> (s, sub.expr sub e)) fields) | Texp_letmodule (id, s, mexpr, exp) -> Texp_letmodule (id, s, sub.module_expr sub mexpr, sub.expr sub exp) | Texp_letexception (cd, exp) -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b1e462db07..235d3895e9 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1228,6 +1228,20 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lfor_of (param, transl_exp iterable, transl_exp body) | Texp_for_await_of (param, _, iterable, body) -> Lfor_await_of (param, transl_exp iterable, transl_exp body) + | Texp_object_literal fields -> + let labels = + List.map + (fun ((s : string Asttypes.loc), _) -> + { + External_arg_spec.obj_arg_label = External_arg_spec.obj_label s.txt; + obj_arg_type = External_arg_spec.Nothing; + }) + fields + in + Lprim + ( Pjs_object_create labels, + List.map (fun (_, field) -> transl_exp field) fields, + e.exp_loc ) | Texp_send (expr, nm) -> (* A setter member only ever occurs applied (recognized in the [Texp_apply] case); a bare occurrence cannot be compiled. *) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index b0e7e24f2c..fd97181927 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -183,12 +183,13 @@ let iter_expression f e = List.iter (fun {x = e} -> expr e) iel | Pexp_open (_, _, e) | Pexp_assert e - | Pexp_send (e, _) | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) | Pexp_letexception (_, e) + | Pexp_send (e, _) | Pexp_field (e, _) -> expr e + | Pexp_object_literal fields -> List.iter (fun (_, e) -> expr e) fields | Pexp_while (e1, e2) | Pexp_sequence (e1, e2) | Pexp_setfield (e1, _, e2) -> expr e1; @@ -3300,6 +3301,42 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_extra = (Texp_coerce cty', loc, sexp.pexp_attributes) :: arg.exp_extra; } + | Pexp_object_literal sfields -> + (* Fields are typed in source order. A duplicate name is typed against the + first occurrence's type and appears once in the row (the runtime object + still writes every field, in order; JavaScript keeps the last value). *) + let seen : (string, type_expr) Hashtbl.t = Hashtbl.create 8 in + let fields = + List.map + (fun ((s : string loc), sfield) -> + match Hashtbl.find_opt seen s.txt with + | Some ty -> (s, type_expect ~context:None env sfield ty) + | None -> + let field = type_exp ~context:None env sfield in + Hashtbl.add seen s.txt field.exp_type; + (s, field)) + sfields + in + let emitted : (string, unit) Hashtbl.t = Hashtbl.create 8 in + let row = + List.fold_right + (fun ((s : string loc), (field : Typedtree.expression)) rest -> + if Hashtbl.mem emitted s.txt then rest + else ( + Hashtbl.add emitted s.txt (); + newty + (Tfield (s.txt, Fpresent, newty (Tpoly (field.exp_type, [])), rest)))) + fields (newty Tnil) + in + rue + { + exp_desc = Texp_object_literal fields; + exp_loc = loc; + exp_extra = []; + exp_type = newty (Tobject row); + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } | Pexp_send (e, {txt = met}) -> ( let obj = type_exp ~context:None env e in try diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index d2a0a4d4b5..4693945614 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -124,6 +124,7 @@ and expression_desc = * direction_flag * expression | Texp_send of expression * string + | Texp_object_literal of (string Asttypes.loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index af91174207..60ad0448d2 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -225,6 +225,7 @@ and expression_desc = * direction_flag * expression | Texp_send of expression * string + | Texp_object_literal of (string Asttypes.loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression | Texp_assert of expression diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index bf6da3f8d7..9407e22fb4 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -287,6 +287,8 @@ end = struct iter_expression exp1; iter_expression exp2 | Texp_send (exp, _meth) -> iter_expression exp + | Texp_object_literal fields -> + List.iter (fun (_, e) -> iter_expression e) fields | Texp_letmodule (_id, _, mexpr, exp) -> iter_module_expr mexpr; iter_expression exp diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index d7ccc5545f..13d022444a 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -722,6 +722,16 @@ module Sexp_ast = struct | Pexp_coerce (expr, (), typexpr) -> Sexp.list [Sexp.atom "Pexp_coerce"; expression expr; core_type typexpr] | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] + | Pexp_object_literal fields -> + Sexp.list + [ + Sexp.atom "Pexp_object_literal"; + Sexp.list + (map_empty + ~f:(fun ((s : string Asttypes.loc), e) -> + Sexp.list [Sexp.atom s.txt; expression e]) + fields); + ] | Pexp_letmodule (mod_name, mod_expr, expr) -> Sexp.list [ diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 66f3e5f71f..6ed5896fff 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1069,12 +1069,10 @@ and walk_expression expr t comments = attach t.leading expr2.pexp_loc leading; walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing - | Pexp_extension - ( {txt = "obj"}, - PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] - ) -> + | Pexp_object_literal fields -> walk_list - (Ext_list.map rows (fun {lid; x = e} -> ExprRecordRow (lid, e))) + (Ext_list.map fields (fun ((s : string Asttypes.loc), e) -> + ExprRecordRow (Location.mkloc (Longident.Lident s.txt) s.loc, e))) t comments | Pexp_extension extension -> walk_extension extension t comments | Pexp_letexception (extension_constructor, expr2) -> diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index e2300349e3..c1d85198ed 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -3537,11 +3537,16 @@ and parse_record_expr_with_string_keys ~start_pos first_row p = ~closing:Rbrace ~f:parse_record_expr_row_with_string_key p in let loc = mk_loc start_pos p.end_pos in - let record_str_expr = - Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) + let fields = + Ext_list.map rows (fun {Parsetree.lid; x} -> + let name = + match lid.txt with + | Longident.Lident name -> Location.mkloc name lid.loc + | _ -> assert false + in + (name, x)) in - Ast_helper.Exp.extension ~loc - (Location.mkloc "obj" loc, Parsetree.PStr [record_str_expr]) + Ast_helper.Exp.object_literal ~loc fields and parse_record_expr ~start_pos ?(spread = None) rows p = let exprs = diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index d35777628b..5906975b74 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -101,9 +101,10 @@ let unary_expr_operand expr = | { pexp_desc = ( Pexp_assert _ | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ - | Pexp_for_await_of _ | Pexp_ifthenelse _ ); + | Pexp_extension _ (* readability? maybe remove *) + | Pexp_object_literal _ (* ({"a": 1})["a"] *) | Pexp_match _ | Pexp_try _ + | Pexp_while _ | Pexp_for _ | Pexp_for_of _ | Pexp_for_await_of _ + | Pexp_ifthenelse _ ); } -> Parenthesized | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized @@ -264,9 +265,10 @@ let field_expr expr = | { pexp_desc = ( Pexp_assert _ | Pexp_extension _ (* %extension.x vs (%extension).x *) - | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ - | Pexp_for_await_of _ | Pexp_ifthenelse _ ); + | Pexp_object_literal _ (* ({"a": 1})["a"] *) | Pexp_fun _ + | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ | Pexp_try _ + | Pexp_while _ | Pexp_for _ | Pexp_for_of _ | Pexp_for_await_of _ + | Pexp_ifthenelse _ ); } -> Parenthesized | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized @@ -335,8 +337,9 @@ let jsx_prop_expr expr = Parsetree.pexp_desc = ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + | Pexp_object_literal _ | Pexp_extension _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | Pexp_let _ + | Pexp_tuple _ ); pexp_attributes = []; } -> Nothing @@ -372,8 +375,9 @@ let jsx_child_expr expr = Parsetree.pexp_desc = ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_jsx_element _ ); + | Pexp_object_literal _ | Pexp_extension _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | Pexp_let _ + | Pexp_jsx_element _ ); pexp_attributes = []; } -> Nothing diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 148a6ce63b..e4f0c64f28 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -267,8 +267,7 @@ let is_huggable_expression expr = | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "obj"}, _) - | Pexp_record _ -> + | Pexp_object_literal _ | Pexp_record _ -> true | _ when is_block_expr expr -> true | _ when is_braced_expr expr -> true @@ -277,10 +276,7 @@ let is_huggable_expression expr = let is_huggable_rhs expr = match expr.pexp_desc with - | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "obj"}, _) - | Pexp_record _ -> - true + | Pexp_array _ | Pexp_tuple _ | Pexp_object_literal _ | Pexp_record _ -> true | _ when is_braced_expr expr -> true | _ -> false diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index e5b90e4d88..115ec6b11f 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -3577,40 +3577,37 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.rbrace; ]) + | Pexp_object_literal fields -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let loc = e.pexp_loc in + let force_break = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (Ext_list.map fields + (fun ((s : string Asttypes.loc), e) -> + print_bs_object_row ~state + (Location.mkloc (Longident.Lident s.txt) s.loc, e) + cmt_tbl)); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) | Pexp_extension extension -> ( match extension with - | ( {txt = "obj"}, - PStr - [ - { - pstr_loc = loc; - pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let force_break = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakable_group ~force_break - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (Ext_list.map rows (fun {lid; x = e} -> - print_bs_object_row ~state (lid, e) cmt_tbl)); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rbrace; - ]) | ( {txt = "re"}, PStr [ diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt index d311f0c80c..832dae26d7 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt +++ b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt @@ -489,7 +489,6 @@ addRecordLabelDeclaration renderVehicle Hooks.res:66:14 path:+Hooks.RenderPropRequiresConversion.props addValueDeclaration +car Hooks.res:67:8 path:+Hooks.RenderPropRequiresConversion addValueReference Hooks.res:68:30 --> Hooks.res:67:8 - addValueReference Hooks.res:68:18 --> Hooks.res:68:18 addValueReference Hooks.res:68:4 --> Hooks.res:66:14 addTypeReference _none_:1:-1 --> Hooks.res:66:14 addValueReference Hooks.res:66:6 --> React.res:16:0 @@ -1735,7 +1734,6 @@ addValueReference Types.res:23:8 --> Types.res:23:8 addValueReference Types.res:23:8 --> Types.res:23:16 addValueReference Types.res:23:8 --> Types.res:23:8 - addValueReference Types.res:23:8 --> Types.res:24:2 addRecordLabelDeclaration self Types.res:31:26 path:+Types.selfRecursive addRecordLabelDeclaration b Types.res:34:31 path:+Types.mutuallyRecursiveA addRecordLabelDeclaration a Types.res:35:26 path:+Types.mutuallyRecursiveB @@ -1750,7 +1748,6 @@ addRecordLabelDeclaration i Types.res:78:2 path:+Types.record addRecordLabelDeclaration s Types.res:79:2 path:+Types.record addValueReference Types.res:83:4 --> Types.res:83:23 - addValueReference Types.res:103:4 --> Types.res:103:39 addValueReference Types.res:119:4 --> Types.res:119:16 addRecordLabelDeclaration id Types.res:124:19 path:+Types.someRecord addValueReference Types.res:129:4 --> Types.res:129:36 @@ -2107,8 +2104,8 @@ Forward Liveness Analysis decls: 744 - roots(external targets): 162 - decl-deps: decls_with_out=452 edges_to_decls=323 + roots(external targets): 161 + decl-deps: decls_with_out=451 edges_to_decls=323 Root (external ref): Value +FirstClassModules.M.InnerModule2.+k Root (external ref): VariantCase DeadRT.moduleAccessPath.Root diff --git a/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt b/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt index 8bc83dda75..9c606bd23f 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt @@ -1,6 +1,5 @@ Complete src/CompletionObjects.res 5:7 posCursor:[5:7] posNoWhite:[5:5] Found expr:[2:10->9:1] -posCursor:[5:7] posNoWhite:[5:5] Found expr:[2:10->9:1] posCursor:[5:7] posNoWhite:[5:5] Found pattern:__ghost__[0:-1->7:5] posCursor:[5:7] posNoWhite:[5:5] Found pattern:__ghost__[0:-1->7:5] Completable: Cpattern Value[x] diff --git a/tests/build_tests/super_errors/expected/dict_helper.res.expected b/tests/build_tests/super_errors/expected/dict_helper.res.expected index b2e35e89b7..04fb8a4dda 100644 --- a/tests/build_tests/super_errors/expected/dict_helper.res.expected +++ b/tests/build_tests/super_errors/expected/dict_helper.res.expected @@ -8,6 +8,6 @@ 4 │ This has type: {"test": string} - But it's expected to have type: dict + But this function argument is expecting: dict Dicts are written like: dict{"a": 1, "b": 2} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_literal_passed_when_record_expected.res.expected b/tests/build_tests/super_errors/expected/object_literal_passed_when_record_expected.res.expected index 4139fe3e09..d76b067b8c 100644 --- a/tests/build_tests/super_errors/expected/object_literal_passed_when_record_expected.res.expected +++ b/tests/build_tests/super_errors/expected/object_literal_passed_when_record_expected.res.expected @@ -7,8 +7,8 @@ 4 │ let x: xx = [{"one": true}] 5 │ - This has type: {"one": bool} - But it's expected to have type: x + This array item has type: {"one": bool} + But this array is expected to have items of type: x You're passing a ReScript object where a record is expected. Objects are written with quoted keys, and records with unquoted keys. diff --git a/tests/syntax_tests/data/ast-mapping/ObjectLiterals.res b/tests/syntax_tests/data/ast-mapping/ObjectLiterals.res new file mode 100644 index 0000000000..be2dcd1c36 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/ObjectLiterals.res @@ -0,0 +1,9 @@ +let simple = {"a": 1, "b": true} + +let nested = {"x": {"y": {"z": 3}}, "s": "hello"} + +let read = nested["x"]["y"] + +let write = (o: {.."a": int}) => o["a"] = 2 + +let inAcall = Console.log({"tag": "point", "value": 1}) diff --git a/tests/syntax_tests/data/ast-mapping/expected/ObjectLiterals.res.txt b/tests/syntax_tests/data/ast-mapping/expected/ObjectLiterals.res.txt new file mode 100644 index 0000000000..be2dcd1c36 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/ObjectLiterals.res.txt @@ -0,0 +1,9 @@ +let simple = {"a": 1, "b": true} + +let nested = {"x": {"y": {"z": 3}}, "s": "hello"} + +let read = nested["x"]["y"] + +let write = (o: {.."a": int}) => o["a"] = 2 + +let inAcall = Console.log({"tag": "point", "value": 1}) diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/object.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/object.res.txt index ee71fe5563..0849bc2a2d 100644 --- a/tests/syntax_tests/data/parsing/errors/expressions/expected/object.res.txt +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/object.res.txt @@ -1,2 +1,2 @@ let obj = - [%obj { \x37 = {js|octal escape|js}; \x7b = {js|another octal escape|js} }] \ No newline at end of file + {"\x37": {js|octal escape|js}, "\x7b": {js|another octal escape|js}} \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/bsObject.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/bsObject.res.txt index fde558c18c..ccfacfb92e 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/bsObject.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/bsObject.res.txt @@ -1,10 +1,9 @@ let zero = 0 -let x = [%obj { age = 30 }] -let y = [%obj { age = 30 }] -let y = [%obj { age = 30; name = {js|steve|js} }] -let y = [%obj { age = 30; name = {js|steve|js} }] -let z = - [%obj { \xff = 1; \u2212 = {js|two|js}; \0 = zero; \o123 = {js|o123|js} }] +let x = {"age": 30} +let y = {"age": 30} +let y = {"age": 30, "name": {js|steve|js}} +let y = {"age": 30, "name": {js|steve|js}} +let z = {"\xff": 1, "\u2212": {js|two|js}, "\0": zero, "\o123": {js|o123|js}} let x = (({js|age|js})[@res.braces ]) let x = (({js|age|js}.(0))[@res.braces ]) let x = (({js|age|js} -> Console.log)[@res.braces ]) diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt index 374cc781ae..aa79fde7a0 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/objectTypeSpreading.res.txt @@ -7,12 +7,9 @@ type nonrec t = < a ;u: int > -> unit (a:1) type nonrec t = (< a ;u: int > as 'a) -> unit (a:1) type nonrec t = < a ;u: int > -> < a ;v: int > -> unit (a:2) type nonrec user = < name: string > -let (steve : < user ;age: int > ) = - [%obj { name = {js|Steve|js}; age = 30 }] -let steve = - ([%obj { name = {js|Steve|js}; age = 30 }] : < user ;age: int > ) -let steve = - ((([%obj { name = {js|Steve|js}; age = 30 }] : < user ;age: int > )) +let (steve : < user ;age: int > ) = {"name": {js|Steve|js}, "age": 30} +let steve = ({"name": {js|Steve|js}, "age": 30} : < user ;age: int > ) +let steve = ((({"name": {js|Steve|js}, "age": 30} : < user ;age: int > )) [@res.braces ]) let printFullUser [arity:1](steve : < user ;age: int > ) = Console.log steve @@ -24,7 +21,7 @@ let printFullUser [arity:1]?(user= (steve : < user ;age: int > )) = Console.log steve external steve : < user ;age: int > = "steve"[@@val ] let makeCeoOf30yearsOld [arity:1]name = - ([%obj { name; age = 30 }] : < user ;age: int > ) + ({"name": name, "age": 30} : < user ;age: int > ) type nonrec optionalUser = < user ;age: int > option type nonrec optionalTupleUser = (< user ;age: int > * < user ;age: int > ) option From 75d68dfa7aec40d14ba948bf7565b998947cd76a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 28 Aug 2026 11:36:49 +0200 Subject: [PATCH 06/13] Make object-field mutability a typed concept (Stage D) Object rows now carry mutability per field instead of encoding writability as a phantom mangled member. Tfield becomes a record with a linkable mutability cell in the field_kind mold: field_mutability = Mutability_value of mutable_flag | Mutability_link of field_mutability ref Mutability_link is pure representation (a union-find edge), never a third source-level state; Btype.mutability_repr reads the class value. Every field constrained to share a mutability shares one equivalence class, so a promotion is seen by all views at once. @set is consumed by typetexp; the frontend's setter mangling ("x#=" members, the synthetic #= operator handling, the setter-suffix literals, the # property-name restriction) is deleted end to end. Property access becomes structural at every layer: the parser produces Pexp_object_get/Pexp_object_set (send terminology removed), the typedtree mirrors them, and translation maps them directly onto the Stage B primitives. The frozen-parsetree bridge encodes the setter as the historical #=-application over a send and decodes it back. Assignment types through Ctype.filter_object_field_for_write: Mutable fields accept writes; an Immutable field of an open row is promoted on the class representative (set_mutability, a logged Cmutability change); a closed row yields the new Object_field_not_mutable error suggesting @set; a missing field reports the field name rather than a mangled member. The cell obeys three laws. Classes are merged only by unification (unify_fields links representatives; both the promotion and the link are trail-logged, so speculative checks restore value and structure). Enlargement allocates: build_subtype gives changed fields independent cells, so trial unification against the approximation can never grant capability to the declared coercion target; settable payloads stay rigid under enlarge_type, and subtype_fields encodes mutable-target pairs as deferred unification constraints over wrapped field fragments. Copying follows the row variable's sharing law: instantiating a generalized row (generic terminator, decided once per row via a memoized policy walk) duplicates each class once per copy so aliases stay correlated within the instance while the scheme and siblings are untouched; other copies share the representative so promotions reach every occurrence; saving emits value cells while preserving class sharing. Copy-session state (the inherited Tsubst/field_kind restoration lists and the new mutability memo) moves into an explicit, nestable, exception-safe session stack in Btype (with_copy_session); instantiation, substitution, and the nondep entry points all own scoped sessions, which is required because nondep copying can expand an abbreviation and expansion instantiates - a nested cleanup of a flat session would split classes mid-copy. cleanup_types is no longer exported, so a copy path cannot forget its session. Four soundness flips from the design land as errors with fixtures: object_setter_type_mismatch and object_coercion_setter_narrower (payload rigidity), object_write_alias (a write through an annotated alias strengthens the shared constraint - agreeing with object_write_original_after_alias, and order-independent), and object_write_after_forgetting (a coercion never grants write capability). Diagnostics and the outcome printer resugar @set (including {..@set "x": t} demands); gentype reads the flag instead of sniffing "#="; editor completion, hints, and semantic tokens handle the new nodes. chain_code_test drops its reliance on the removed getter/setter type split. Generated JavaScript is byte-identical across the corpus except the intended flips. The representation-level unit suite ounit_object_mutability_tests.ml (16 tests) covers class merging and order independence, backtracking of promotion and links, instance independence and intra-instance aliasing, structure-generalized sharing, terminator/class sharing across every copy path, nondep session lifecycle (direct, nested expansion, failure), and saving (value-only cells, class sharing, a Marshal round trip). ERROR_VARIANTS.md records the new fixtures. Magics: cmi Caml1999I028, cmt Caml1999T029, ast ResImpl01303/ResIntf01303. Stage D of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- analysis/reanalyze/src/arnold.ml | 7 +- analysis/reanalyze/src/side_effects.ml | 3 +- analysis/src/completion_front_end.ml | 12 +- analysis/src/hint.ml | 4 +- analysis/src/type_utils.ml | 10 +- analysis/src/utils.ml | 3 +- compiler/ext/config.ml | 8 +- compiler/ext/literals.ml | 4 - compiler/frontend/ast_attributes.ml | 7 - compiler/frontend/ast_attributes.mli | 5 - compiler/frontend/ast_core_type_class_type.ml | 51 +- compiler/frontend/ast_exp_apply.ml | 21 +- compiler/frontend/ast_util.ml | 2 +- compiler/gentype/runtime.ml | 10 - compiler/gentype/runtime.mli | 2 - compiler/gentype/translate_core_type.ml | 20 +- .../gentype/translate_type_expr_from_types.ml | 174 +++-- compiler/ml/ast_helper.ml | 3 +- compiler/ml/ast_helper.mli | 5 +- compiler/ml/ast_iterator.ml | 5 +- compiler/ml/ast_mapper.ml | 5 +- compiler/ml/ast_mapper_from0.ml | 11 +- compiler/ml/ast_mapper_to0.ml | 12 +- compiler/ml/btype.ml | 171 ++++- compiler/ml/btype.mli | 12 +- compiler/ml/ctype.ml | 613 ++++++++++++------ compiler/ml/ctype.mli | 29 +- compiler/ml/depend.ml | 5 +- compiler/ml/includecore.ml | 3 +- compiler/ml/oprint.ml | 10 +- compiler/ml/outcometree.ml | 3 +- compiler/ml/parsetree.ml | 3 +- compiler/ml/pprintast.ml | 6 +- compiler/ml/printast.ml | 8 +- compiler/ml/printtyp.ml | 48 +- compiler/ml/printtyped.ml | 8 +- compiler/ml/rec_check.ml | 8 +- compiler/ml/record_type_spread.ml | 3 +- compiler/ml/subst.ml | 112 ++-- compiler/ml/tast_iterator.ml | 5 +- compiler/ml/tast_mapper.ml | 4 +- compiler/ml/translcore.ml | 20 +- compiler/ml/typecore.ml | 101 ++- compiler/ml/typecore.mli | 1 + compiler/ml/typedecl.ml | 8 +- compiler/ml/typedtree.ml | 3 +- compiler/ml/typedtree.mli | 3 +- compiler/ml/typedtree_iter.ml | 5 +- compiler/ml/types.ml | 12 +- compiler/ml/types.mli | 33 +- compiler/ml/typetexp.ml | 39 +- compiler/syntax/src/res_ast_debugger.ml | 4 +- compiler/syntax/src/res_comments_table.ml | 12 +- compiler/syntax/src/res_core.ml | 18 +- compiler/syntax/src/res_outcome_printer.ml | 3 +- compiler/syntax/src/res_parens.ml | 3 +- compiler/syntax/src/res_printer.ml | 106 +-- tests/ERROR_VARIANTS.md | 1 + .../tests/src/CompletionObjects.res | 5 + .../tests/src/expected/Completion.res.txt | 16 +- .../src/expected/CompletionObjects.res.txt | 11 + ...ject_coercion_mutable_unequal.res.expected | 8 +- ...rcion_promote_readonly_caller.res.expected | 4 +- ..._coercion_readonly_to_mutable.res.expected | 2 +- ...ject_coercion_setter_narrower.res.expected | 14 + ...ct_open_write_readonly_caller.res.expected | 4 +- .../object_setter_type_mismatch.res.expected | 14 + ...object_write_after_forgetting.res.expected | 12 + ...te_after_open_target_coercion.res.expected | 6 +- .../expected/object_write_alias.res.expected | 11 + .../object_write_closed_row.res.expected | 6 +- ...ct_write_original_after_alias.res.expected | 11 + .../object_coercion_setter_narrower.res | 8 + .../fixtures/object_setter_type_mismatch.res | 8 + .../object_write_after_forgetting.res | 8 + .../fixtures/object_write_alias.res | 13 + .../object_write_original_after_alias.res | 12 + .../ounit_object_mutability_tests.ml | 394 +++++++++++ tests/ounit_tests/ounit_tests_main.ml | 1 + .../other/expected/breadcrumbs170.res.txt | 2 +- .../grammar/expressions/expected/jsx.res.txt | 14 +- .../expressions/expected/primary.res.txt | 12 +- .../printer/expr/expected/jsObjectSet.res.txt | 2 + .../data/printer/expr/jsObjectSet.res | 2 + tests/tests/src/chain_code_test.mjs | 2 +- tests/tests/src/chain_code_test.res | 2 +- tests/tests/src/object_mutability_pin.mjs | 24 +- tests/tests/src/object_mutability_pin.res | 51 +- 88 files changed, 1729 insertions(+), 757 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/object_coercion_setter_narrower.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_setter_type_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_after_forgetting.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_alias.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_original_after_alias.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_coercion_setter_narrower.res create mode 100644 tests/build_tests/super_errors/fixtures/object_setter_type_mismatch.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_after_forgetting.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_alias.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_original_after_alias.res create mode 100644 tests/ounit_tests/ounit_object_mutability_tests.ml diff --git a/analysis/reanalyze/src/arnold.ml b/analysis/reanalyze/src/arnold.ml index 9c3591febb..05050c731e 100644 --- a/analysis/reanalyze/src/arnold.ml +++ b/analysis/reanalyze/src/arnold.ml @@ -1003,8 +1003,11 @@ module Compile = struct | Texp_for_await_of (_id, _pat, e1, e2) -> let open Command in expression ~ctx e1 +++ expression ~ctx e2 - | Texp_send _ -> - not_implemented "Texp_send"; + | Texp_object_get _ -> + not_implemented "Texp_object_get"; + assert false + | Texp_object_set _ -> + not_implemented "Texp_object_set"; assert false | Texp_letmodule _ -> not_implemented "Texp_letmodule"; diff --git a/analysis/reanalyze/src/side_effects.ml b/analysis/reanalyze/src/side_effects.ml index 8e8ef833d8..d11bbaf9e2 100644 --- a/analysis/reanalyze/src/side_effects.ml +++ b/analysis/reanalyze/src/side_effects.ml @@ -65,7 +65,8 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = e1 |> expr_no_side_effects && e2 |> expr_no_side_effects && e3 |> expr_no_side_effects | Texp_for_of _ | Texp_for_await_of _ -> false - | Texp_send _ -> false + | Texp_object_get _ -> false + | Texp_object_set _ -> false | Texp_letexception (_ec, e) -> e |> expr_no_side_effects | Texp_pack _ -> false | Texp_extension_constructor _ when true -> true diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index eb8d5b39a4..70f08d3699 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -254,7 +254,7 @@ let rec expr_to_context_path_inner ~(in_jsx_context : bool) expr_loc = e1.pexp_loc; in_jsx = in_jsx_context; }) - | Pexp_send (e1, {txt}) -> ( + | Pexp_object_get (e1, {txt}) -> ( match expr_to_context_path ~in_jsx_context e1 with | None -> None | Some contex_path -> Some (CPObj (contex_path, txt))) @@ -1580,7 +1580,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file |> iterate_fn_arguments ~is_pipe:false ~args ~iterator; reset_current_ctx_path old_ctx_path) | Some arg_completable -> set_result arg_completable) - | Pexp_send (lhs, {txt; loc}) -> ( + | (Pexp_object_get (lhs, {txt; loc}) as object_access) + | (Pexp_object_set (lhs, {txt; loc}, _) as object_access) -> ( (* e["txt"] If the string for txt is not closed, it could go over several lines. Only take the first like to represent the label *) @@ -1596,7 +1597,12 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file ((l, c + 1), (l, c + 1 + String.length label)) in if debug then - Printf.printf "Pexp_send %s%s e:%s\n" label + Printf.printf "%s %s%s e:%s\n" + (match object_access with + | Pexp_object_get _ -> "Pexp_object_get" + | Pexp_object_set _ -> "Pexp_object_set" + | _ -> assert false) + label (Range.to_string label_range) (Loc.to_string lhs.pexp_loc); if diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 0d28b7f2b3..0f0d2b0e48 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -62,8 +62,8 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = pexp_desc = ( Pexp_constant _ | Pexp_tuple _ | Pexp_record _ | Pexp_variant _ | Pexp_apply _ | Pexp_match _ | Pexp_construct _ | Pexp_ifthenelse _ - | Pexp_array _ | Pexp_ident _ | Pexp_try _ | Pexp_send _ - | Pexp_field _ | Pexp_open _ | Pexp_fun _ ); + | Pexp_array _ | Pexp_ident _ | Pexp_try _ | Pexp_object_get _ + | Pexp_object_set _ | Pexp_field _ | Pexp_open _ | Pexp_fun _ ); }; } -> push vb.pvb_pat.ppat_loc Type diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 1f4be403b5..3e35433ad4 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -35,7 +35,7 @@ let rec has_tvar (ty : Types.type_expr) : bool = | Ttuple tyl -> List.exists has_tvar tyl | Tconstr (_, tyl, _) -> List.exists has_tvar tyl | Tobject ty -> has_tvar ty - | Tfield (_, _, ty1, ty2) -> has_tvar ty1 || has_tvar ty2 + | Tfield {typ = ty1; rest = ty2} -> has_tvar ty1 || has_tvar ty2 | Tnil -> false | Tlink ty -> has_tvar ty | Tsubst ty -> has_tvar ty @@ -157,7 +157,8 @@ let instantiate_type ~type_params ~type_args (t : Types.type_expr) = } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject t -> {t with desc = Tobject (loop t)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tfield f -> + {t with desc = Tfield {f with typ = loop f.typ; rest = loop f.rest}} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} | Tpackage (p, l, tl) -> @@ -218,7 +219,8 @@ let instantiate_type2 ?(type_arg_context : type_arg_context option) } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject t -> {t with desc = Tobject (loop t)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tfield f -> + {t with desc = Tfield {f with typ = loop f.typ; rest = loop f.rest}} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} | Tpackage (p, l, tl) -> @@ -1334,7 +1336,7 @@ let remove_current_module_if_needed ~env_completion_is_made_from completion_path let rec get_obj_fields (texp : Types.type_expr) = match texp.desc with - | Tfield (name, _, t1, t2) -> + | Tfield {name; typ = t1; rest = t2} -> let fields = t2 |> get_obj_fields in (name, t1) :: fields | Tlink te | Tsubst te | Tpoly (te, []) -> te |> get_obj_fields diff --git a/analysis/src/utils.ml b/analysis/src/utils.ml index 54eecc8d7b..35d7f19e67 100644 --- a/analysis/src/utils.ml +++ b/analysis/src/utils.ml @@ -107,7 +107,8 @@ let identify_pexp pexp = | Pexp_for_await_of _ -> "Pexp_for_await_of" | Pexp_constraint _ -> "Pexp_constraint" | Pexp_coerce _ -> "Pexp_coerce" - | Pexp_send _ -> "Pexp_send" + | Pexp_object_get _ -> "Pexp_object_get" + | Pexp_object_set _ -> "Pexp_object_set" | Pexp_object_literal _ -> "Pexp_object_literal" | Pexp_letmodule _ -> "Pexp_letmodule" | Pexp_letexception _ -> "Pexp_letexception" diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index d6f7f9f94b..9ad1d9dfea 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,10 +1,10 @@ -let cmi_magic_number = "Caml1999I026" +let cmi_magic_number = "Caml1999I028" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01302" +and ast_impl_magic_number = "ResImpl01303" -and ast_intf_magic_number = "ResIntf01302" +and ast_intf_magic_number = "ResIntf01303" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T027" +and cmt_magic_number = "Caml1999T029" let load_path = ref ([] : string list) diff --git a/compiler/ext/literals.ml b/compiler/ext/literals.ml index 884a1934b9..9f6e9ce70e 100644 --- a/compiler/ext/literals.ml +++ b/compiler/ext/literals.ml @@ -50,10 +50,6 @@ let runtime = "runtime" (* runtime directory *) let stdlib = "stdlib" -let setter_suffix = "#=" - -let setter_suffix_len = String.length setter_suffix - let debugger = "debugger" let fn_run = "fn_run" diff --git a/compiler/frontend/ast_attributes.ml b/compiler/frontend/ast_attributes.ml index f586356369..166b04390a 100644 --- a/compiler/frontend/ast_attributes.ml +++ b/compiler/frontend/ast_attributes.ml @@ -25,13 +25,6 @@ type attr = Parsetree.attribute type t = attr list -let process_object_field_attributes_rev (attrs : t) : bool * t = - Ext_list.fold_left attrs (false, []) - (fun (has_set, acc) (({txt}, payload) as attr) -> - match (txt, payload) with - | "set", Parsetree.PStr [] -> (true, acc) - | _ -> (has_set, attr :: acc)) - type attr_kind = Nothing | Meth_callback of attr let process_attributes_rev (attrs : t) : attr_kind * t = diff --git a/compiler/frontend/ast_attributes.mli b/compiler/frontend/ast_attributes.mli index 699b53b26d..9915f17531 100644 --- a/compiler/frontend/ast_attributes.mli +++ b/compiler/frontend/ast_attributes.mli @@ -25,11 +25,6 @@ type attr = Parsetree.attribute type t = attr list -val process_object_field_attributes_rev : t -> bool * t -(** Recognizes the bare [@set] marker on an object-type field. Returns whether - the field is settable, plus the remaining attributes. Any other form is - left in place and ignored, like any unrecognized attribute. *) - type attr_kind = Nothing | Meth_callback of attr val process_attributes_rev : t -> attr_kind * t diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index 70399a3c6b..267d829938 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -21,19 +21,6 @@ * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let process_getter_setter ~not_getter_setter - ~(get : Parsetree.core_type -> _ -> Parsetree.attributes -> _) ~set name - (attrs : Ast_attributes.t) (ty : Parsetree.core_type) (acc : _ list) = - match Ast_attributes.process_object_field_attributes_rev attrs with - | false, _ -> not_getter_setter ty :: acc - | true, pctf_attributes -> - set ty - ({name with txt = name.Asttypes.txt ^ Literals.setter_suffix} - : _ Asttypes.loc) - pctf_attributes - :: get ty name pctf_attributes - :: acc - let default_typ_mapper = Ast_mapper.default_mapper.typ (* Attributes are very hard to attribute @@ -78,37 +65,15 @@ let typ_mapper (self : Ast_mapper.mapper) (ty : Parsetree.core_type) = match meth_ with | Parsetree.Oinherit _ -> meth_ :: acc | Parsetree.Otag (label, ptyp_attrs, core_type) -> - let get ty name attrs = - let attrs, core_type = - match Ast_attributes.process_attributes_rev attrs with - | Nothing, attrs -> (attrs, ty) (* #1678 *) - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Parsetree.Otag (name, attrs, self.typ self core_type) - in - let set ty name attrs = - let attrs, core_type = - match Ast_attributes.process_attributes_rev attrs with - | Nothing, attrs -> (attrs, ty) - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Parsetree.Otag - ( name, - attrs, - Ast_helper.Typ.arrow ~loc - [{attrs = []; lbl = Nolabel; typ = self.typ self core_type}] - (Ast_literal.type_unit ~loc ()) ) - in - let not_getter_setter ty = - let attrs, core_type = - match Ast_attributes.process_attributes_rev ptyp_attrs with - | Nothing, attrs -> (attrs, ty) - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Parsetree.Otag (label, attrs, self.typ self core_type) + (* Field attributes (including @set, consumed during type + checking) stay on the field; only method-callback attributes + move onto the field's type. *) + let attrs, core_type = + match Ast_attributes.process_attributes_rev ptyp_attrs with + | Nothing, attrs -> (attrs, core_type) + | Meth_callback attr, attrs -> (attrs, attr +> core_type) in - process_getter_setter ~not_getter_setter ~get ~set label ptyp_attrs - core_type acc) + Parsetree.Otag (label, attrs, self.typ self core_type) :: acc) in {ty with ptyp_desc = Ptyp_object (new_methods, closed_flag)} | _ -> default_typ_mapper self ty diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index c6fbeda749..5f4924bb27 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -57,11 +57,6 @@ type app_pattern = { args: Parsetree.expression list; } -let sane_property_name_check loc s = - if String.contains s '#' then - Location.raise_errorf ~loc - "property name (%s) can not contain speical character #" s - (* match fn as *) let view_as_app (fn : exp) (s : string list) : app_pattern option = match fn.pexp_desc with @@ -70,7 +65,7 @@ let view_as_app (fn : exp) (s : string list) : app_pattern option = Some {op; loc = fn.pexp_loc; args = check_and_discard args} | _ -> None -let infix_ops = ["->"; "#="] +let infix_ops = ["->"] let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = match view_as_app e infix_ops with @@ -132,20 +127,6 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = pexp_loc = f.pexp_loc; }) | _ -> Exp.apply ~loc ~attrs:e.pexp_attributes f [(Nolabel, a)]) - | Some {op = "#="; loc; args = [obj; arg]} -> ( - let gen_assignment obj name name_loc = - sane_property_name_check name_loc name; - let obj = self.expr self obj in - let arg = self.expr self arg in - let fn = Exp.send ~loc obj {txt = name ^ Literals.setter_suffix; loc} in - Exp.constraint_ ~loc - (Exp.apply ~loc fn [(Nolabel, arg)]) - (Ast_literal.type_unit ~loc ()) - in - match obj.pexp_desc with - | Pexp_send (obj, {txt = name; loc = name_loc}) -> - gen_assignment obj name name_loc - | _ -> Location.raise_errorf ~loc "invalid #= assignment") | Some {op = "->"; loc} -> Location.raise_errorf ~loc "Invalid pipe syntax. The pipe symbol (->) can only be used as a binary \ diff --git a/compiler/frontend/ast_util.ml b/compiler/frontend/ast_util.ml index ccb94d5c03..12c5f08f5f 100644 --- a/compiler/frontend/ast_util.ml +++ b/compiler/frontend/ast_util.ml @@ -23,4 +23,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let js_property loc obj (name : string) = - Parsetree.Pexp_send (obj, {loc; txt = name}) + Parsetree.Pexp_object_get (obj, {loc; txt = name}) diff --git a/compiler/gentype/runtime.ml b/compiler/gentype/runtime.ml index 8fe4729a8e..468d97d0c2 100644 --- a/compiler/gentype/runtime.ml +++ b/compiler/gentype/runtime.ml @@ -28,14 +28,4 @@ let js_variant_value ~polymorphic = | true -> "VAL" | false -> "value" -let is_mutable_object_field name = - String.length name >= 2 - && (String.sub name (String.length name - 2) 2 [@doesNotRaise]) = "#=" - -(** Mutable fields, i.e. fields annotated "[@set]" - are represented as extra fields called "fieldName#=" - preceding the normal field. *) -let check_mutable_object_field ~previous_name ~name = - previous_name = name ^ "#=" - let default = "$$default" diff --git a/compiler/gentype/runtime.mli b/compiler/gentype/runtime.mli index 390661d000..cb70cec49a 100644 --- a/compiler/gentype/runtime.mli +++ b/compiler/gentype/runtime.mli @@ -5,11 +5,9 @@ type module_access_path = | Root of string | Dot of module_access_path * module_item -val check_mutable_object_field : previous_name:string -> name:string -> bool val default : string val emit_module_access_path : config:Config.t -> module_access_path -> string -val is_mutable_object_field : string -> bool val new_module_item : name:string -> module_item val js_variant_tag : polymorphic:bool -> tag:string option -> string val js_variant_payload_tag : n:int -> string diff --git a/compiler/gentype/translate_core_type.ml b/compiler/gentype/translate_core_type.ml index 25eabe8323..92a5c1dbed 100644 --- a/compiler/gentype/translate_core_type.ml +++ b/compiler/gentype/translate_core_type.ml @@ -113,13 +113,23 @@ and translateCoreType_ ~config ~type_vars_gen | Ttyp_object (t_obj, closed_flag) -> let get_field_type object_field = match object_field with - | Typedtree.OTtag ({txt = name}, _, t) -> + | Typedtree.OTtag ({txt = name}, attrs, t) -> + let mutable_ = + if + List.exists + (fun (({txt}, payload) : Parsetree.attribute) -> + txt = "set" && payload = Parsetree.PStr []) + attrs + then Mutable + else Immutable + in ( name, - match name |> Runtime.is_mutable_object_field with - | true -> {dependencies = []; type_ = ident ""} - | false -> t |> translateCoreType_ ~config ~type_vars_gen ~type_env ) + mutable_, + t |> translateCoreType_ ~config ~type_vars_gen ~type_env ) | OTinherit t -> - ("Inherit", t |> translateCoreType_ ~config ~type_vars_gen ~type_env) + ( "Inherit", + Immutable, + t |> translateCoreType_ ~config ~type_vars_gen ~type_env ) in let fields_translations = t_obj |> List.map get_field_type in translate_obj_type diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index db6061eae1..38bc9b1218 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -24,34 +24,24 @@ let rec path_to_list path = let translate_obj_type closed_flag fields_translations = let dependencies = fields_translations - |> List.map (fun (_, {dependencies}) -> dependencies) + |> List.map (fun (_, _, {dependencies}) -> dependencies) |> List.concat in - let rec check_mutable_field ?(acc = []) fields = - match fields with - | (previous_name, {type_ = _}) :: (name, {type_}) :: rest - when Runtime.check_mutable_object_field ~previous_name ~name -> - (* The field was annotated "@set" *) - rest |> check_mutable_field ~acc:((name, type_, Mutable) :: acc) - | (name, {type_}) :: rest -> - rest |> check_mutable_field ~acc:((name, type_, Immutable) :: acc) - | [] -> acc |> List.rev - in let fields = - fields_translations |> check_mutable_field - |> List.map (fun (name, t, mutable_) -> - let optional, type_ = - match t with - | Option t -> (Optional, t) - | _ -> (Mandatory, t) - in - { - mutable_; - name_js = name; - optional; - type_; - doc_string = Doc_string.empty; - }) + fields_translations + |> List.map (fun (name, mutable_, {type_ = t}) -> + let optional, type_ = + match t with + | Option t -> (Optional, t) + | _ -> (Mandatory, t) + in + { + mutable_; + name_js = name; + optional; + type_; + doc_string = Doc_string.empty; + }) in let type_ = Object (closed_flag, fields) in {dependencies; type_} @@ -511,14 +501,14 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env | Tobject t_obj -> let rec get_field_types (texp : Types.type_expr) = match texp.desc with - | Tfield (name, _, t1, t2) -> + | Tfield {name; mutability; typ = t1; rest = t2} -> let closed_flafg, fields = t2 |> get_field_types in ( closed_flafg, ( name, - match name |> Runtime.is_mutable_object_field with - | true -> {dependencies = []; type_ = ident ""} - | false -> - t1 |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + (match Btype.mutability_repr mutability with + | Asttypes.Mutable -> Mutable + | Immutable -> Immutable), + t1 |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env ) :: fields ) | Tlink te -> te |> get_field_types @@ -561,10 +551,11 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let no_payloads = no_payloads |> List.map (fun label -> - { - label_js = - (if is_number label then IntLabel label else StringLabel label); - }) + { + label_js = + (if is_number label then IntLabel label + else StringLabel label); + }) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads:[] ~polymorphic:true @@ -581,14 +572,15 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let payload_translations = payloads |> List.map (fun (label, payload) -> - ( label, - payload - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env )) + ( label, + payload + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + )) in let payloads = payload_translations |> List.map (fun (label, translation) -> - {case = {label_js = StringLabel label}; t = translation.type_}) + {case = {label_js = StringLabel label}; t = translation.type_}) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads ~polymorphic:true @@ -607,9 +599,10 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let type_equations_translation = (List.combine ids types [@doesNotRaise]) |> List.map (fun (x, t) -> - ( x, - t |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - )) + ( x, + t + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + )) in let type_equations = type_equations_translation @@ -645,50 +638,53 @@ and signature_to_module_runtime_representation ~config ~type_vars_gen ~type_env let dependencies_and_fields = signature |> List.map (fun signature_item -> - match signature_item with - | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) - | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> - let {dependencies; type_} = - type_expr - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = Annotation.doc_string_from_attrs val_attributes; - } - in - (dependencies, [field]) - | Types.Sig_module (id, module_declaration, _recStatus) -> - let type_env1 = - match type_env |> Type_env.get_module ~name:(id |> Ident.name) with - | Some type_env1 -> type_env1 - | None -> type_env - in - let dependencies, type_ = - match module_declaration.md_type with - | Mty_signature signature -> - signature - |> signature_to_module_runtime_representation ~config - ~type_vars_gen ~type_env:type_env1 - | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = - Annotation.doc_string_from_attrs - module_declaration.md_attributes; - } - in - (dependencies, [field]) - | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> ([], [])) + match signature_item with + | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) + | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> + let {dependencies; type_} = + type_expr + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = Annotation.doc_string_from_attrs val_attributes; + } + in + (dependencies, [field]) + | Types.Sig_module (id, module_declaration, _recStatus) -> + let type_env1 = + match + type_env |> Type_env.get_module ~name:(id |> Ident.name) + with + | Some type_env1 -> type_env1 + | None -> type_env + in + let dependencies, type_ = + match module_declaration.md_type with + | Mty_signature signature -> + signature + |> signature_to_module_runtime_representation ~config + ~type_vars_gen ~type_env:type_env1 + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = + Annotation.doc_string_from_attrs + module_declaration.md_attributes; + } + in + (dependencies, [field]) + | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> + ([], [])) in let dependencies, fields = let dl, fl = dependencies_and_fields |> List.split in @@ -704,7 +700,7 @@ let translate_type_expr_from_types ~config ~type_env type_expr = if !Debug.dependencies then translation.dependencies |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string)); + Log_.item "Dependency: %s\n" (dep |> dep_to_string)); translation let translate_type_exprs_from_types ~config ~type_env type_exprs = @@ -715,7 +711,7 @@ let translate_type_exprs_from_types ~config ~type_env type_exprs = if !Debug.dependencies then translations |> List.iter (fun translation -> - translation.dependencies - |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string))); + translation.dependencies + |> List.iter (fun dep -> + Log_.item "Dependency: %s\n" (dep |> dep_to_string))); translations diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 6381ae626f..64e8b05f2d 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -187,7 +187,8 @@ module Exp = struct mk ?loc ?attrs (Pexp_for_await_of (a, b, c)) let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let object_get ?loc ?attrs a b = mk ?loc ?attrs (Pexp_object_get (a, b)) + let object_set ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_object_set (a, b, c)) let object_literal ?loc ?attrs a = mk ?loc ?attrs (Pexp_object_literal a) let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 9a7a3385df..a52aa951cf 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -205,7 +205,10 @@ module Exp : sig val coerce : ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression val constraint_ : ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression - val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val object_get : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + + val object_set : + ?loc:loc -> ?attrs:attrs -> expression -> str -> expression -> expression val object_literal : ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 180664308b..462e1af60c 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -360,7 +360,10 @@ module E = struct | Pexp_constraint (e, t) -> sub.expr sub e; sub.typ sub t - | Pexp_send (e, _s) -> sub.expr sub e + | Pexp_object_get (e, _s) -> sub.expr sub e + | Pexp_object_set (e, _s, v) -> + sub.expr sub e; + sub.expr sub v | Pexp_object_literal fields -> List.iter (fun (s, e) -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 400db4ce76..f536bda077 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -348,7 +348,10 @@ module E = struct coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_get (e, s) -> + object_get ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_set (e, s, v) -> + object_set ~loc ~attrs (sub.expr sub e) (map_loc sub s) (sub.expr sub v) | Pexp_object_literal fields -> object_literal ~loc ~attrs (List.map (fun (s, e) -> (map_loc sub s, sub.expr sub e)) fields) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index fed41b7e58..60e5215922 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -567,6 +567,14 @@ module E = struct fun_ ~loc ~attrs [{p_attrs = []; p_lbl = Nolabel; p_default = None; p_pat = pat}] body + | Pexp_apply + ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [ + (Asttypes.Noloc.Nolabel, {pexp_desc = Pexp_send (e, s)}); + (Asttypes.Noloc.Nolabel, v); + ] ) -> + (* Decode the v0 encoding of property assignment. *) + object_set ~loc ~attrs (sub.expr sub e) (map_loc sub s) (sub.expr sub v) | Pexp_apply ({pexp_desc = Pexp_ident tag_name}, args) when has_jsx_attribute () -> ( let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in @@ -763,7 +771,8 @@ module E = struct coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_send (e, s) -> + object_get ~loc ~attrs (sub.expr sub e) (map_loc sub s) | Pexp_extension ( {txt = "obj"}, PStr diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 70830bee41..0e975bcfb7 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -592,7 +592,17 @@ module E = struct coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) | Pexp_constraint (e, t) -> constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_get (e, s) -> + send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_object_set (e, s, v) -> + (* v0 encoding: application of the "#=" operator to a send. *) + let s = map_loc sub s in + apply ~loc ~attrs + (Ast_helper0.Exp.ident ~loc {txt = Longident.Lident "#="; loc}) + [ + (Asttypes.Noloc.Nolabel, Ast_helper0.Exp.send ~loc (sub.expr sub e) s); + (Asttypes.Noloc.Nolabel, sub.expr sub v); + ] | Pexp_object_literal fields -> (* v0 encoding: the reserved %obj extension over a record expression. *) let rows = diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 4359713094..2cef2413c7 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -83,6 +83,7 @@ type change = (Path.t * type_expr list) option ref * (Path.t * type_expr list) option | Crow of row_field option ref * row_field option | Ckind of field_kind option ref * field_kind option + | Cmutability of field_mutability ref * field_mutability | Cuniv of type_expr option ref * type_expr option | Ctypeset of Type_set.t ref * Type_set.t @@ -106,7 +107,8 @@ let rec field_kind_repr = function let rec repr_link compress t d = function | {desc = Tlink t' as d'} -> repr_link true t d' t' - | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> + | {desc = Tfield {presence = k; rest = t'} as d'} + when field_kind_repr k = Fabsent -> repr_link true t d' t' | t' -> if compress then ( @@ -117,7 +119,7 @@ let rec repr_link compress t d = function let repr t = match t.desc with | Tlink t' as d -> repr_link false t d t' - | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> + | Tfield {presence = k; rest = t'} as d when field_kind_repr k = Fabsent -> repr_link false t d t' | _ -> t @@ -198,7 +200,7 @@ let proxy ty = | Tobject ty -> let rec proxy_obj ty = match ty.desc with - | Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty + | Tfield {rest = ty} | Tlink ty -> proxy_obj ty | Tvar _ | Tunivar _ | Tconstr _ -> ty | Tnil -> ty0 | _ -> assert false @@ -214,7 +216,7 @@ let row_of_type t = let rec get_row t = let t = repr t in match t.desc with - | Tfield (_, _, _, t) -> get_row t + | Tfield {rest = t} -> get_row t | _ -> t in get_row t @@ -264,7 +266,7 @@ let iter_type_expr f ty = | Tvariant row -> iter_row f row; f (row_more row) - | Tfield (_, _, ty1, ty2) -> + | Tfield {typ = ty1; rest = ty2} -> f ty1; f ty2 | Tnil -> () @@ -411,6 +413,104 @@ let rec norm_univar ty = | Ttuple (ty :: _) -> norm_univar ty | _ -> assert false +(* Chase mutability links to the terminal cell. *) +let rec mutability_ref_repr (r : field_mutability ref) = + match !r with + | Mutability_link r' -> mutability_ref_repr r' + | Mutability_value _ -> r + +let mutability_repr r = + match !(mutability_ref_repr r) with + | Mutability_value flag -> flag + | Mutability_link _ -> assert false + +type type_copy_session = { + mutable saved_desc: (type_expr * type_desc) list; + mutable saved_kinds: field_kind option ref list; + mutable new_kinds: field_kind option ref list; + mutable saved_mutabilities: (field_mutability ref * field_mutability) list; + mutable new_mutabilities: field_mutability ref list; + mutable copy_policy_memo: (int, bool) Hashtbl.t option; +} + +let type_copy_sessions = ref [] + +let begin_type_copy_session () = + type_copy_sessions := + { + saved_desc = []; + saved_kinds = []; + new_kinds = []; + saved_mutabilities = []; + new_mutabilities = []; + copy_policy_memo = None; + } + :: !type_copy_sessions + +let current_type_copy_session () = + match !type_copy_sessions with + | session :: _ -> session + | [] -> assert false + +let end_type_copy_session () = + match !type_copy_sessions with + | session :: rest -> + List.iter (fun (ty, desc) -> ty.desc <- desc) session.saved_desc; + List.iter (fun r -> r := None) session.saved_kinds; + List.iter (fun (r, v) -> r := v) session.saved_mutabilities; + type_copy_sessions := rest + | [] -> assert false + +(* Duplicate a mutability cell for the current copy session: the original + representative is temporarily linked to the duplicate, so every field + copied in this session that shares the cell reaches the same duplicate + (the [dup_kind] idiom); [cleanup_types] restores the originals. *) +let dup_mutability r = + let session = current_type_copy_session () in + let r = mutability_ref_repr r in + if List.memq r session.new_mutabilities then r + else + let r' = ref !r in + session.new_mutabilities <- r' :: session.new_mutabilities; + session.saved_mutabilities <- (r, !r) :: session.saved_mutabilities; + r := Mutability_link r'; + r' + +(* Copy policy for an object row, memoized per node so copying a row is + linear in its length: duplicate the mutability cells iff the row ends in + a generic variable (a scheme instantiation); share them otherwise (a + structure-generalized copy, whose occurrences must see promotions). *) +let row_terminator_generic rest = + let session = current_type_copy_session () in + let copy_policy_memo = + match session.copy_policy_memo with + | Some memo -> memo + | None -> + let memo = Hashtbl.create 17 in + session.copy_policy_memo <- Some memo; + memo + in + let rec go t = + let t = repr t in + match Hashtbl.find_opt copy_policy_memo t.id with + | Some b -> b + | None -> + let b = + match t.desc with + | Tfield {rest} -> go rest + | Tvar _ -> t.level = generic_level + | Tsubst t' -> + (* Already copied in this session: follow the copy; its fresh + terminator is generic exactly when the row is being + instantiated. *) + go t' + | _ -> false + in + Hashtbl.add copy_policy_memo t.id b; + b + in + go rest + let rec copy_type_desc ?(keep_names = false) f = function | Tvar _ as ty -> if keep_names then ty else Tvar None | Tarrow (params, ret) -> @@ -419,9 +519,26 @@ let rec copy_type_desc ?(keep_names = false) f = function | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) | Tobject ty -> Tobject (f ty) | Tvariant _ -> assert false (* too ambiguous *) - | Tfield (p, k, ty1, ty2) -> - (* the kind is kept shared *) - Tfield (p, field_kind_repr k, f ty1, f ty2) + | Tfield f_ -> + (* The presence kind is kept shared. The mutability cell follows the + row variable's sharing law: instantiating a generalized row (generic + terminator) duplicates each cell once per session via + [dup_mutability], so aliases within the instance stay correlated + while the scheme and sibling instances are untouched; other copies + hold the shared representative, so promotions reach every + occurrence. *) + let mutability = + if row_terminator_generic f_.rest then dup_mutability f_.mutability + else mutability_ref_repr f_.mutability + in + Tfield + { + f_ with + presence = field_kind_repr f_.presence; + mutability; + typ = f f_.typ; + rest = f f_.rest; + } | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc | Tsubst _ -> assert false @@ -433,30 +550,33 @@ let rec copy_type_desc ?(keep_names = false) f = function (* Utilities for copying *) -let saved_desc = ref [] -(* Saved association of generic nodes with their description. *) +let save_desc ty desc = + let session = current_type_copy_session () in + session.saved_desc <- (ty, desc) :: session.saved_desc -let save_desc ty desc = saved_desc := (ty, desc) :: !saved_desc - -let saved_kinds = ref [] (* duplicated kind variables *) -let new_kinds = ref [] (* new kind variables *) let dup_kind r = + let session = current_type_copy_session () in (match !r with | None -> () | Some _ -> assert false); - if not (List.memq r !new_kinds) then ( - saved_kinds := r :: !saved_kinds; + if not (List.memq r session.new_kinds) then ( + session.saved_kinds <- r :: session.saved_kinds; let r' = ref None in - new_kinds := r' :: !new_kinds; + session.new_kinds <- r' :: session.new_kinds; r := Some (Fvar r')) (* Restored type descriptions. *) -let cleanup_types () = - List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc; - List.iter (fun r -> r := None) !saved_kinds; - saved_desc := []; - saved_kinds := []; - new_kinds := [] +let cleanup_types () = end_type_copy_session () + +let with_copy_session f = + begin_type_copy_session (); + match f () with + | result -> + cleanup_types (); + result + | exception exn -> + cleanup_types (); + raise exn (* Mark a type. *) let rec mark_type ty = @@ -614,6 +734,7 @@ let undo_change = function | Cname (r, v) -> r := v | Crow (r, v) -> r := v | Ckind (r, v) -> r := v + | Cmutability (r, v) -> r := v | Cuniv (r, v) -> r := v | Ctypeset (r, v) -> r := v @@ -656,6 +777,10 @@ let set_name nm v = let set_row_field e v = log_change (Crow (e, !e)); e := Some v +let set_mutability r v = + log_change (Cmutability (r, !r)); + r := v + let set_kind rk k = log_change (Ckind (rk, !rk)); rk := Some k diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index fb5edad610..3f8b9db6f7 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -136,8 +136,7 @@ val save_desc : type_expr -> type_desc -> unit val dup_kind : field_kind option ref -> unit (* Save a None field_kind, and make it point to a fresh Fvar *) -val cleanup_types : unit -> unit -(* Restore type descriptions *) +val with_copy_session : (unit -> 'a) -> 'a val lowest_level : int (* Marked type: ty.level < lowest_level *) @@ -218,6 +217,15 @@ val set_name : val set_row_field : row_field option ref -> row_field -> unit val set_univar : type_expr option ref -> type_expr -> unit val set_kind : field_kind option ref -> field_kind -> unit + +(* Logged (backtrackable) update of a mutability cell: promotion + ([Mutability_value Mutable]) or an equivalence-class merge + ([Mutability_link]). *) +val set_mutability : field_mutability ref -> field_mutability -> unit + +(* Terminal cell of a link chain / its semantic value. *) +val mutability_ref_repr : field_mutability ref -> field_mutability ref +val mutability_repr : field_mutability ref -> Asttypes.mutable_flag val set_typeset : Type_set.t ref -> Type_set.t -> unit (* Set references, logging the old value *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 41d1c74a7e..e261184a00 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -261,7 +261,16 @@ let is_datatype decl = (* Miscellaneous operations on object types *) (**********************************************) -type fields = (string * Types.field_kind * Types.type_expr) list +type field_info = { + f_name: string; + f_kind: Types.field_kind; + f_mut: Types.field_mutability ref; + (* the field's cell as stored; read its class value with + [Btype.mutability_repr] *) + f_typ: Types.type_expr; +} + +type fields = field_info list (**** Object field manipulation. ****) let object_fields ty = @@ -273,27 +282,38 @@ let flatten_fields (ty : Types.type_expr) : fields * _ = let rec flatten (l : fields) ty = let ty = repr ty in match ty.desc with - | Tfield (s, k, ty1, ty2) -> flatten ((s, k, ty1) :: l) ty2 + | Tfield {name; presence; mutability; typ; rest} -> + flatten + ({f_name = name; f_kind = presence; f_mut = mutability; f_typ = typ} + :: l) + rest | _ -> (l, ty) in let l, r = flatten [] ty in - (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) + (List.sort (fun f f' -> compare f.f_name f'.f_name) l, r) let build_fields level = - List.fold_right (fun (s, k, ty1) ty2 -> - newty2 level (Tfield (s, k, ty1, ty2))) + List.fold_right (fun {f_name; f_kind; f_mut; f_typ} rest -> + newty2 level + (Tfield + { + name = f_name; + presence = f_kind; + mutability = f_mut; + typ = f_typ; + rest; + })) let associate_fields (fields1 : fields) (fields2 : fields) : _ * fields * fields = let rec associate p s s' : fields * fields -> _ = function | l, [] -> (List.rev p, List.rev s @ l, List.rev s') | [], l' -> (List.rev p, List.rev s, List.rev s' @ l') - | (n, k, t) :: r, (n', k', t') :: r' when n = n' -> - associate ((n, k, t, k', t') :: p) s s' (r, r') - | (n, k, t) :: r, ((n', _k', _t') :: _ as l') when n < n' -> - associate p ((n, k, t) :: s) s' (r, l') - | ((_n, _k, _t) :: _ as l), (n', k', t') :: r' (* when n > n' *) -> - associate p s ((n', k', t') :: s') (l, r') + | f :: r, f' :: r' when f.f_name = f'.f_name -> + associate ((f, f') :: p) s s' (r, r') + | f :: r, (f' :: _ as l') when f.f_name < f'.f_name -> + associate p (f :: s) s' (r, l') + | l, f' :: r' (* when name > name' *) -> associate p s (f' :: s') (l, r') in associate [] [] [] (fields1, fields2) @@ -304,7 +324,7 @@ let rec object_row ty = let ty = repr ty in match ty.desc with | Tobject t -> object_row t - | Tfield (_, _, _, t) -> object_row t + | Tfield {rest = t} -> object_row t | _ -> ty let opened_object ty = @@ -376,7 +396,7 @@ let rec free_vars_rec real ty = with Not_found -> ()); List.iter (free_vars_rec true) tl | Tobject ty, _ -> free_vars_rec false ty - | Tfield (_, _, ty1, ty2), _ -> + | Tfield {typ = ty1; rest = ty2}, _ -> free_vars_rec true ty1; free_vars_rec false ty2 | Tvariant row, _ -> @@ -587,7 +607,7 @@ let rec update_level env level expand ty = | _ -> ()); set_level ty level; iter_type_expr (update_level env level expand) ty - | Tfield (lab, _, ty1, _) + | Tfield {name = lab; typ = ty1} when lab = dummy_method && (repr ty1).level > level -> raise (Unify [(ty1, newvar2 level)]) | _ -> @@ -830,7 +850,7 @@ let rec copy ?env ?partial ?keep_names ty = more.desc <- Tsubst (newgenty (Ttuple [more'; t])); (* Return a new copy *) Tvariant (copy_row copy true row keep more')) - | Tfield (_p, k, _ty1, ty2) -> ( + | Tfield {presence = k; rest = ty2} -> ( match field_kind_repr k with | Fabsent -> Tlink (copy ty2) | Fpresent -> copy_type_desc copy desc @@ -848,26 +868,21 @@ let simple_copy t = copy t let gadt_env env = if Env.has_local_constraints env then Some env else None let instance ?partial env sch = - let env = gadt_env env in - let partial = - match partial with - | None -> None - | Some keep -> Some (compute_univars sch, keep) - in - let ty = copy ?env ?partial sch in - cleanup_types (); - ty + with_copy_session (fun () -> + let env = gadt_env env in + let partial = + match partial with + | None -> None + | Some keep -> Some (compute_univars sch, keep) + in + copy ?env ?partial sch) -let instance_def sch = - let ty = copy sch in - cleanup_types (); - ty +let instance_def sch = with_copy_session (fun () -> copy sch) let instance_list env schl = - let env = gadt_env env in - let tyl = List.map (fun t -> copy ?env t) schl in - cleanup_types (); - tyl + with_copy_session (fun () -> + let env = gadt_env env in + List.map (fun t -> copy ?env t) schl) let reified_var_counter = ref Vars.empty let reset_reified_var_counter () = reified_var_counter := Vars.empty @@ -898,35 +913,35 @@ let new_declaration newtype manifest = } let instance_constructor ?in_pattern cstr = - (match in_pattern with - | None -> () - | Some (env, newtype_lev) -> - let process existential = - let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in - let name = - match repr existential with - | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name - | _ -> "$" ^ cstr.cstr_name - in - let path = Path.Pident (Ident.create (get_new_abstract_name name)) in - let new_env = Env.add_local_type path decl !env in - env := new_env; - let to_unify = newty (Tconstr (path, [], ref Mnil)) in - let tv = copy existential in - assert (is_Tvar tv); - link_type tv to_unify - in - List.iter process cstr.cstr_existentials); - let ty_res = copy cstr.cstr_res in - let ty_args = List.map simple_copy cstr.cstr_args in - cleanup_types (); - (ty_args, ty_res) + with_copy_session (fun () -> + (match in_pattern with + | None -> () + | Some (env, newtype_lev) -> + let process existential = + let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + let name = + match repr existential with + | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | _ -> "$" ^ cstr.cstr_name + in + let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let new_env = Env.add_local_type path decl !env in + env := new_env; + let to_unify = newty (Tconstr (path, [], ref Mnil)) in + let tv = copy existential in + assert (is_Tvar tv); + link_type tv to_unify + in + List.iter process cstr.cstr_existentials); + let ty_res = copy cstr.cstr_res in + let ty_args = List.map simple_copy cstr.cstr_args in + (ty_args, ty_res)) let instance_parameterized_type ?keep_names sch_args sch = - let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in - let ty = copy sch in - cleanup_types (); - (ty_args, ty) + with_copy_session (fun () -> + let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in + let ty = copy sch in + (ty_args, ty)) let map_kind f = function | Type_abstract -> Type_abstract @@ -946,16 +961,13 @@ let map_kind f = function Type_record (List.map (fun l -> {l with ld_type = f l.ld_type}) fl, rr) let instance_declaration decl = - let decl = - { - decl with - type_params = List.map simple_copy decl.type_params; - type_manifest = may_map simple_copy decl.type_manifest; - type_kind = map_kind simple_copy decl.type_kind; - } - in - cleanup_types (); - decl + with_copy_session (fun () -> + { + decl with + type_params = List.map simple_copy decl.type_params; + type_manifest = may_map simple_copy decl.type_manifest; + type_kind = map_kind simple_copy decl.type_kind; + }) (**** Instantiation for types with free universal variables ****) @@ -1024,30 +1036,30 @@ let rec copy_sep fixed free bound visited ty = t let instance_poly ?(keep_names = false) fixed univars sch = - let univars = List.map repr univars in - let copy_var ty = - match ty.desc with - | Tunivar name -> if keep_names then newty (Tvar name) else newvar () - | _ -> assert false - in - let vars = List.map copy_var univars in - let pairs = List.map2 (fun u v -> (u, (v, []))) univars vars in - delayed_copy := []; - let ty = copy_sep fixed (compute_univars sch) [] pairs sch in - List.iter Lazy.force !delayed_copy; - delayed_copy := []; - cleanup_types (); - (vars, ty) + with_copy_session (fun () -> + let univars = List.map repr univars in + let copy_var ty = + match ty.desc with + | Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let pairs = List.map2 (fun u v -> (u, (v, []))) univars vars in + delayed_copy := []; + let ty = copy_sep fixed (compute_univars sch) [] pairs sch in + List.iter Lazy.force !delayed_copy; + delayed_copy := []; + (vars, ty)) let instance_label fixed lbl = - let ty_res = copy lbl.lbl_res in - let vars, ty_arg = - match repr lbl.lbl_arg with - | {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty - | _ -> ([], copy lbl.lbl_arg) - in - cleanup_types (); - (vars, ty_arg, ty_res) + with_copy_session (fun () -> + let ty_res = copy lbl.lbl_res in + let vars, ty_arg = + match repr lbl.lbl_arg with + | {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty + | _ -> ([], copy lbl.lbl_arg) + in + (vars, ty_arg, ty_res)) (**** Instantiation with parameter substitution ****) @@ -1811,7 +1823,7 @@ and mcomp_fields type_pairs env ty1 ty2 = let fields1, rest1 = flatten_fields ty1 in let pairs, miss1, miss2 = associate_fields fields1 fields2 in let has_present = - List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) + List.exists (fun f -> field_kind_repr f.f_kind = Fpresent) in mcomp type_pairs env rest1 rest2; if @@ -1819,10 +1831,9 @@ and mcomp_fields type_pairs env ty1 ty2 = || (has_present miss2 && (object_row ty1).desc = Tnil) then raise (Unify []); List.iter - (function - | _n, k1, t1, k2, t2 -> - mcomp_kind k1 k2; - mcomp type_pairs env t1 t2) + (fun (f1, f2) -> + mcomp_kind f1.f_kind f2.f_kind; + mcomp type_pairs env f1.f_typ f2.f_typ) pairs and mcomp_kind k1 k2 = @@ -2257,7 +2268,8 @@ and unify3 env t1 t1' t2 t2' = reify env t1'; reify env t2'; if !generate_equations then mcomp !env t1' t2') - | Tfield (f, kind, _, rem), Tnil | Tnil, Tfield (f, kind, _, rem) -> ( + | Tfield {name = f; presence = kind; rest = rem}, Tnil + | Tnil, Tfield {name = f; presence = kind; rest = rem} -> ( match field_kind_repr kind with | Fvar r when f <> dummy_method -> set_kind r Fabsent; @@ -2324,6 +2336,9 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = and fields2, rest2 = flatten_fields ty2 in let pairs, miss1, miss2 = associate_fields fields1 fields2 in let l1 = (repr ty1).level and l2 = (repr ty2).level in + (* Row openness before the rests are instantiated below: an [Immutable] + field may be promoted to [Mutable] only while its row is open. *) + let open1 = is_Tvar (repr rest1) and open2 = is_Tvar (repr rest2) in let va = make_rowvar (Ext_pervasives.min_int l1 l2) @@ -2334,16 +2349,33 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = unify env (build_fields l1 miss1 va) rest2; unify env rest1 (build_fields l2 miss2 va); List.iter - (fun (n, k1, t1, k2, t2) -> - unify_kind k1 k2; + (fun (f1, f2) -> + unify_kind f1.f_kind f2.f_kind; + unify_mutability ~open1 ~open2 f1 f2; try - if !trace_gadt_instances then update_level !env va.level t1; - unify env t1 t2 + if !trace_gadt_instances then update_level !env va.level f1.f_typ; + unify env f1.f_typ f2.f_typ with Unify trace -> raise (Unify - (( newty (Tfield (n, k1, t1, newty Tnil)), - newty (Tfield (n, k2, t2, newty Tnil)) ) + (( newty + (Tfield + { + name = f1.f_name; + presence = f1.f_kind; + mutability = f1.f_mut; + typ = f1.f_typ; + rest = newty Tnil; + }), + newty + (Tfield + { + name = f2.f_name; + presence = f2.f_kind; + mutability = f2.f_mut; + typ = f2.f_typ; + rest = newty Tnil; + }) ) :: trace))) pairs with exn -> @@ -2353,6 +2385,24 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = rest2.desc <- d2; raise exn +and unify_mutability ~open1 ~open2 f1 f2 = + let r1 = mutability_ref_repr f1.f_mut and r2 = mutability_ref_repr f2.f_mut in + if r1 != r2 then ( + (match (!r1, !r2) with + | Mutability_value Immutable, Mutability_value Immutable + | Mutability_value Mutable, Mutability_value Mutable -> + () + | Mutability_value Immutable, Mutability_value Mutable -> + if open1 then set_mutability r1 (Mutability_value Asttypes.Mutable) + else raise (Unify []) + | Mutability_value Mutable, Mutability_value Immutable -> + if open2 then set_mutability r2 (Mutability_value Asttypes.Mutable) + else raise (Unify []) + | Mutability_link _, _ | _, Mutability_link _ -> assert false); + (* Merge the two equivalence classes: linking the representatives makes + every present and future member of either class share one state. *) + set_mutability r2 (Mutability_link r1)) + and unify_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in @@ -2638,16 +2688,20 @@ let rec filter_method_field env name priv ty = let ty' = newty2 level (Tfield - ( name, - (match priv with - | Private -> Fvar (ref None) - | Public -> Fpresent), - ty1, - ty2 )) + { + name; + presence = + (match priv with + | Private -> Fvar (ref None) + | Public -> Fpresent); + mutability = ref (Mutability_value Asttypes.Immutable); + typ = ty1; + rest = ty2; + }) in link_type ty ty'; ty1 - | Tfield (n, kind, ty1, ty2) -> + | Tfield {name = n; presence = kind; typ = ty1; rest = ty2} -> let kind = field_kind_repr kind in if n = name && kind <> Fabsent then ( if priv = Public then unify_kind kind Fpresent; @@ -2655,6 +2709,62 @@ let rec filter_method_field env name priv ty = else filter_method_field env name priv ty2 | _ -> raise (Unify []) +type object_field_write_error = Owrite_missing | Owrite_not_mutable + +(* Look up [name] for assignment in the object type [ty]. + - A [Mutable] field yields its type. + - An [Immutable] field is promoted iff the object row is open; on a + closed row the write is rejected. + - An absent field is added as [Mutable] through an open row; on a closed + row the write is rejected as missing. *) +let filter_object_field_for_write env name ty : + (type_expr, object_field_write_error) Result.t = + let rec write_field ~opened ty = + let ty = expand_head_trace env ty in + match ty.desc with + | Tvar _ -> + let level = ty.level in + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = + newty2 level + (Tfield + { + name; + presence = Fpresent; + mutability = ref (Mutability_value Asttypes.Mutable); + typ = ty1; + rest = ty2; + }) + in + link_type ty ty'; + Ok ty1 + | Tfield ({name = n; presence = kind; mutability; typ} as f) -> + let kind = field_kind_repr kind in + if n = name && kind <> Fabsent then ( + unify_kind kind Fpresent; + match mutability_repr mutability with + | Asttypes.Mutable -> Ok typ + | Immutable -> + if opened then ( + set_mutability + (mutability_ref_repr mutability) + (Mutability_value Asttypes.Mutable); + Ok typ) + else Error Owrite_not_mutable) + else write_field ~opened f.rest + | _ -> Error Owrite_missing + in + let ty = expand_head_trace env ty in + match ty.desc with + | Tvar _ -> + let ty1 = newvar () in + let ty' = newobj ty1 in + update_level env ty.level ty'; + link_type ty ty'; + write_field ~opened:true ty1 + | Tobject f -> write_field ~opened:(opened_object ty) f + | _ -> Error Owrite_missing + (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) let filter_method env name priv ty = let ty = expand_head_trace env ty in @@ -2771,14 +2881,32 @@ and moregen_fields inst_nongen type_pairs env ty1 ty2 = moregen inst_nongen type_pairs env rest1 (build_fields (repr ty2).level miss2 rest2); List.iter - (fun (n, k1, t1, k2, t2) -> - moregen_kind k1 k2; - try moregen inst_nongen type_pairs env t1 t2 + (fun (f1, f2) -> + moregen_kind f1.f_kind f2.f_kind; + if mutability_repr f1.f_mut <> mutability_repr f2.f_mut then + raise (Unify []); + try moregen inst_nongen type_pairs env f1.f_typ f2.f_typ with Unify trace -> raise (Unify - (( newty (Tfield (n, k1, t1, rest2)), - newty (Tfield (n, k2, t2, rest2)) ) + (( newty + (Tfield + { + name = f1.f_name; + presence = f1.f_kind; + mutability = f1.f_mut; + typ = f1.f_typ; + rest = rest2; + }), + newty + (Tfield + { + name = f2.f_name; + presence = f2.f_kind; + mutability = f2.f_mut; + typ = f2.f_typ; + rest = rest2; + }) ) :: trace))) pairs @@ -3059,16 +3187,33 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = eqtype rename type_pairs subst env rest1 rest2; if miss1 <> [] || miss2 <> [] then raise (Unify []); List.iter - (function - | n, k1, t1, k2, t2 -> ( - eqtype_kind k1 k2; - try eqtype rename type_pairs subst env t1 t2 - with Unify trace -> - raise - (Unify - (( newty (Tfield (n, k1, t1, rest2)), - newty (Tfield (n, k2, t2, rest2)) ) - :: trace)))) + (fun (f1, f2) -> + eqtype_kind f1.f_kind f2.f_kind; + if mutability_repr f1.f_mut <> mutability_repr f2.f_mut then + raise (Unify []); + try eqtype rename type_pairs subst env f1.f_typ f2.f_typ + with Unify trace -> + raise + (Unify + (( newty + (Tfield + { + name = f1.f_name; + presence = f1.f_kind; + mutability = f1.f_mut; + typ = f1.f_typ; + rest = rest2; + }), + newty + (Tfield + { + name = f2.f_name; + presence = f2.f_kind; + mutability = f2.f_mut; + typ = f2.f_typ; + rest = rest2; + }) ) + :: trace))) pairs and eqtype_kind k1 k2 = @@ -3301,11 +3446,34 @@ let rec build_subtype env visited loops posi level t = in let t1', c = build_subtype env visited loops posi level' t1 in if c > Unchanged then (newty (Tobject t1'), c) else (t, Unchanged) - | Tfield (s, _, t1, t2) (* Always present *) -> - let t1', c1 = build_subtype env visited loops posi level t1 in + | Tfield ({typ = t1; rest = t2} as f) (* Always present *) -> + let t1', c1 = + match mutability_repr f.mutability with + | Asttypes.Mutable -> + (* Do not enlarge a mutable field's type. The unification performed + after enlargement will then require the source and target field + types to be equivalent. *) + (t1, Unchanged) + | Immutable -> build_subtype env visited loops posi level t1 + in let t2', c2 = build_subtype env visited loops posi level t2 in let c = max c1 c2 in - if c > Unchanged then (newty (Tfield (s, Fpresent, t1', t2')), c) + if c > Unchanged then + ( newty + (Tfield + { + f with + presence = Fpresent; + (* The enlarged type is an approximation, not a view of the + declared type: it gets its own unlinked cell, so trial + unification can never promote the declared target or the + coercion result through it. *) + mutability = + ref (Mutability_value (mutability_repr f.mutability)); + typ = t1'; + rest = t2'; + }), + c ) else (t, Unchanged) | Tnil -> if posi then @@ -3779,9 +3947,41 @@ and subtype_fields env trace ty1 ty2 cstrs = :: cstrs in List.fold_left - (fun cstrs (_, _k1, t1, _k2, t2) -> + (fun cstrs (f1, f2) -> (* These fields are always present *) - subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) + match mutability_repr f2.f_mut with + | Asttypes.Immutable -> + (* Read-only target: covariant; a mutable source just forgets its + write permission. *) + subtype_rec env ((f1.f_typ, f2.f_typ) :: trace) f1.f_typ f2.f_typ cstrs + | Mutable -> + (* Writable target: delegate to unification of the two fields. The + source fragment uses [rest1], so [unify_mutability] can promote an + [Immutable] source field only when the source row is open. Field + type unification also enforces equivalence. *) + let src = + newty + (Tfield + { + name = f1.f_name; + presence = f1.f_kind; + mutability = f1.f_mut; + typ = f1.f_typ; + rest = rest1; + }) + in + let tgt = + newty + (Tfield + { + name = f2.f_name; + presence = f2.f_kind; + mutability = f2.f_mut; + typ = f2.f_typ; + rest = newvar (); + }) + in + (trace, src, tgt, !univar_pairs, None) :: cstrs) cstrs pairs and subtype_row env trace row1 row2 cstrs = @@ -3850,8 +4050,7 @@ let subtype env ty1 ty2 = let rec unalias_object ty = let ty = repr ty in match ty.desc with - | Tfield (s, k, t1, t2) -> - newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) + | Tfield f -> newty2 ty.level (Tfield {f with rest = unalias_object f.rest}) | Tvar _ | Tnil -> newty2 ty.level ty.desc | Tunivar _ -> ty | Tconstr _ -> newvar2 ty.level @@ -3905,7 +4104,7 @@ let rec closed_schema_rec env ty = visited := old; closed_schema_rec env (try_expand_head try_expand_safe env ty) with Cannot_expand -> raise Non_closed0)) - | Tfield (_, kind, t1, t2) -> + | Tfield {presence = kind; typ = t1; rest = t2} -> if field_kind_repr kind = Fpresent then closed_schema_rec env t1; closed_schema_rec env t2 | Tvariant row -> @@ -4005,6 +4204,16 @@ let clear_hash () = Type_hash.clear nondep_hash; Type_hash.clear nondep_variants +let with_nondep_copy_session f = + with_copy_session (fun () -> + match f () with + | result -> + clear_hash (); + result + | exception exn -> + clear_hash (); + raise exn) + let rec nondep_type_rec env id ty = match ty.desc with | Tvar _ | Tunivar _ -> ty @@ -4060,13 +4269,7 @@ let rec nondep_type_rec env id ty = ty') let nondep_type env id ty = - try - let ty' = nondep_type_rec env id ty in - clear_hash (); - ty' - with Not_found -> - clear_hash (); - raise Not_found + with_nondep_copy_session (fun () -> nondep_type_rec env id ty) let () = nondep_type' := nondep_type @@ -4080,76 +4283,72 @@ let unroll_abbrev id tl ty = (* Preserve sharing inside type declarations. *) let nondep_type_decl env mid id is_covariant decl = - try - let params = List.map (nondep_type_rec env mid) decl.type_params in - let tk = - try map_kind (nondep_type_rec env mid) decl.type_kind - with Not_found when is_covariant -> Type_abstract - and tm = - try - match decl.type_manifest with - | None -> None - | Some ty -> Some (unroll_abbrev id params (nondep_type_rec env mid ty)) - with Not_found when is_covariant -> None - in - clear_hash (); - let priv = - match tm with - | Some ty when Btype.has_constr_row ty -> Private - | _ -> decl.type_private - in - { - type_params = params; - type_arity = decl.type_arity; - type_kind = tk; - type_manifest = tm; - type_private = priv; - type_variance = decl.type_variance; - type_newtype_level = None; - type_loc = decl.type_loc; - type_attributes = decl.type_attributes; - type_immediate = decl.type_immediate; - type_representation = decl.type_representation; - type_inlined_types = decl.type_inlined_types; - } - with Not_found -> - clear_hash (); - raise Not_found + with_nondep_copy_session (fun () -> + let params = List.map (nondep_type_rec env mid) decl.type_params in + let tk = + try map_kind (nondep_type_rec env mid) decl.type_kind + with Not_found when is_covariant -> Type_abstract + and tm = + try + match decl.type_manifest with + | None -> None + | Some ty -> + Some (unroll_abbrev id params (nondep_type_rec env mid ty)) + with Not_found when is_covariant -> None + in + let priv = + match tm with + | Some ty when Btype.has_constr_row ty -> Private + | _ -> decl.type_private + in + { + type_params = params; + type_arity = decl.type_arity; + type_kind = tk; + type_manifest = tm; + type_private = priv; + type_variance = decl.type_variance; + type_newtype_level = None; + type_loc = decl.type_loc; + type_attributes = decl.type_attributes; + type_immediate = decl.type_immediate; + type_representation = decl.type_representation; + type_inlined_types = decl.type_inlined_types; + }) (* Preserve sharing inside extension constructors. *) let nondep_extension_constructor env mid ext = - try - let type_path, type_params = - if Path.isfree mid ext.ext_type_path then - let ty = - newgenty (Tconstr (ext.ext_type_path, ext.ext_type_params, ref Mnil)) - in - let ty' = nondep_type_rec env mid ty in - match (repr ty').desc with - | Tconstr (p, tl, _) -> (p, tl) - | _ -> raise Not_found - else - let type_params = - List.map (nondep_type_rec env mid) ext.ext_type_params - in - (ext.ext_type_path, type_params) - in - let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in - let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in - clear_hash (); - { - ext_type_path = type_path; - ext_type_params = type_params; - ext_args = args; - ext_ret_type = ret_type; - ext_private = ext.ext_private; - ext_attributes = ext.ext_attributes; - ext_loc = ext.ext_loc; - ext_is_exception = ext.ext_is_exception; - } - with Not_found -> - clear_hash (); - raise Not_found + with_nondep_copy_session (fun () -> + let type_path, type_params = + if Path.isfree mid ext.ext_type_path then + let ty = + newgenty + (Tconstr (ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env mid ty in + match (repr ty').desc with + | Tconstr (p, tl, _) -> (p, tl) + | _ -> raise Not_found + else + let type_params = + List.map (nondep_type_rec env mid) ext.ext_type_params + in + (ext.ext_type_path, type_params) + in + let args = + map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args + in + let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in + { + ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + ext_is_exception = ext.ext_is_exception; + }) let same_constr env t1 t2 = let t1 = expand_head env t1 in diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 7b609a9c5e..d6dcba52f8 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -101,17 +101,23 @@ val repr : type_expr -> type_expr (* Return the canonical representative of a type. *) val object_fields : type_expr -> type_expr -val flatten_fields : - type_expr -> (string * field_kind * type_expr) list * type_expr -(* Transform a field type into a list of pairs label-type *) -(* The fields are sorted *) +type field_info = { + f_name: string; + f_kind: field_kind; + f_mut: field_mutability ref; + (* the field's cell as stored; read the class value with + [Btype.mutability_repr] *) + f_typ: type_expr; +} + +type fields = field_info list + +val flatten_fields : type_expr -> fields * type_expr + +(* Transform a field type into a sorted list of field infos *) val associate_fields : - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr * field_kind * type_expr) list - * (string * field_kind * type_expr) list - * (string * field_kind * type_expr) list + fields -> fields -> (field_info * field_info) list * fields * fields val opened_object : type_expr -> bool val lid_of_path : ?hash:string -> Path.t -> Longident.t @@ -214,6 +220,11 @@ val filter_arrow_n : parameters with the given labels; return parameter and result types. *) val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr + +type object_field_write_error = Owrite_missing | Owrite_not_mutable + +val filter_object_field_for_write : + Env.t -> string -> type_expr -> (type_expr, object_field_write_error) Result.t (* A special case of unification (with {m : 'a; 'b}). *) val occur_in : Env.t -> type_expr -> type_expr -> bool diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index d9a0f31be9..f9d1db67da 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -279,7 +279,10 @@ let rec add_expr bv exp = | Pexp_constraint (e1, ty2) -> add_expr bv e1; add_type bv ty2 - | Pexp_send (e, _m) -> add_expr bv e + | Pexp_object_get (e, _m) -> add_expr bv e + | Pexp_object_set (e, _m, v) -> + add_expr bv e; + add_expr bv v | Pexp_object_literal fields -> List.iter (fun (_, e) -> add_expr bv e) fields | Pexp_letmodule (id, m, e) -> let b = add_module_binding bv m in diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index af630bf08a..24189819c9 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -139,7 +139,8 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = miss2 = [] && let tl1, tl2 = - List.split (List.map (fun (_, _, t1, _, t2) -> (t1, t2)) pairs) + List.split + (List.map (fun (f1, f2) -> (f1.Ctype.f_typ, f2.Ctype.f_typ)) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) | _ -> diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml index 674d48333a..984c46832b 100644 --- a/compiler/ml/oprint.ml +++ b/compiler/ml/oprint.ml @@ -332,14 +332,16 @@ and print_fields rest ppf = function match rest with | Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") | None -> ()) - | [(s, t)] -> - fprintf ppf "%s : %a" s print_out_type t; + | [(s, mut, t)] -> + fprintf ppf "%s%s : %a" (if mut then "mutable " else "") s print_out_type t; (match rest with | Some _ -> fprintf ppf ";@ " | None -> ()); print_fields rest ppf [] - | (s, t) :: l -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l + | (s, mut, t) :: l -> + fprintf ppf "%s%s : %a;@ %a" + (if mut then "mutable " else "") + s print_out_type t (print_fields rest) l and print_row_field ppf (l, opt_amp, tyl) = let pr_of ppf = diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml index 4b83893b55..351e07dde6 100644 --- a/compiler/ml/outcometree.ml +++ b/compiler/ml/outcometree.ml @@ -56,7 +56,8 @@ type out_type = | Otyp_arrow of (Asttypes.Noloc.arg_label * out_type) list * out_type | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type - | Otyp_object of (string * out_type) list * bool option + | Otyp_object of (string * bool * out_type) list * bool option + (* fields are (name, mutable, type) *) | Otyp_record of (string * bool * bool * out_type) list | Otyp_stuff of string | Otyp_sum of (string * out_type list * out_type option * string option) list diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 585cd77f8d..0d677c4a8c 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -302,7 +302,8 @@ and expression_desc = | Pexp_coerce of expression * unit * core_type (* (E :> T) (None, T) *) - | Pexp_send of expression * label loc (* E # m *) + | Pexp_object_get of expression * label loc (* obj["x"] *) + | Pexp_object_set of expression * label loc * expression (* obj["x"] = v *) | Pexp_object_literal of (label loc * expression) list (* {"a": 1, "b": true} *) | Pexp_letmodule of string loc * module_expr * expression diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index ff1538f2a2..6c6dcf7657 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -769,7 +769,11 @@ and expression2 ctxt f x = match x.pexp_desc with | Pexp_field (e, li) -> pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | Pexp_object_get (e, s) -> + pp f "@[%a[\"%s\"]@]" (simple_expr ctxt) e s.txt + | Pexp_object_set (e, s, v) -> + pp f "@[%a[\"%s\"] =@ %a@]" (simple_expr ctxt) e s.txt + (expression ctxt) v | Pexp_object_literal fields -> pp f "@[{%a}@]" (list ~sep:",@ " (fun f ((s : string Asttypes.loc), e) -> diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index f763d41b49..cd4d7bd148 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -351,8 +351,12 @@ and expression i ppf x = line i ppf "Pexp_coerce\n"; expression i ppf e; core_type i ppf cto2 - | Pexp_send (e, s) -> - line i ppf "Pexp_send \"%s\"\n" s.txt; + | Pexp_object_set (e, s, v) -> + line i ppf "Pexp_object_set \"%s\"\n" s.txt; + expression i ppf e; + expression i ppf v + | Pexp_object_get (e, s) -> + line i ppf "Pexp_object_get \"%s\"\n" s.txt; expression i ppf e | Pexp_letmodule (s, me, e) -> line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index a481784ea0..7c8a47baaa 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -173,9 +173,13 @@ and raw_type_desc ppf = function fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl (raw_list path) (list_of_memo !abbrev) | Tobject t -> fprintf ppf "@[Tobject@,%a@]" raw_type t - | Tfield (f, k, t1, t2) -> - fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (safe_kind_repr [] k) raw_type t1 raw_type t2 + | Tfield {name = f; presence = k; mutability; typ = t1; rest = t2} -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (safe_kind_repr [] k) + (match Btype.mutability_repr mutability with + | Mutable -> "mutable" + | Immutable -> "immutable") + raw_type t1 raw_type t2 | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t @@ -525,13 +529,15 @@ let rec mark_loops_rec visited ty = if opened_object ty then visited_objects := px :: !visited_objects; let fields, _ = flatten_fields fi in List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) + (fun {Ctype.f_kind; f_typ} -> + if field_kind_repr f_kind = Fpresent then + mark_loops_rec visited f_typ) fields) - | Tfield (_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> + | Tfield {presence = kind; typ = ty1; rest = ty2} + when field_kind_repr kind = Fpresent -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield (_, _, _, ty2) -> mark_loops_rec visited ty2 + | Tfield {rest = ty2} -> mark_loops_rec visited ty2 | Tnil -> () | Tsubst ty -> mark_loops_rec visited ty | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" @@ -736,14 +742,15 @@ and tree_of_typobject ?printing_context sch fi = let fields, rest = flatten_fields fi in let present_fields = List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpresent -> (n, t) :: l + (fun {f_name; f_kind; f_mut; f_typ} l -> + match field_kind_repr f_kind with + | Fpresent -> + (f_name, Btype.mutability_repr f_mut = Asttypes.Mutable, f_typ) :: l | _ -> l) fields [] in let sorted_fields = - List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields + List.sort (fun (n, _, _) (n', _, _) -> String.compare n n') present_fields in let fields, rest = tree_of_typfields ?printing_context sch rest sorted_fields @@ -762,8 +769,8 @@ and tree_of_typfields ?printing_context sch rest = function | _ -> fatal_error "typfields (1)" in ([], rest) - | (s, t) :: l -> - let field = (s, tree_of_typexp ?printing_context sch t) in + | (s, mut, t) :: l -> + let field = (s, mut, tree_of_typexp ?printing_context sch t) in let fields, rest = tree_of_typfields ?printing_context sch rest l in (field :: fields, rest) @@ -1294,7 +1301,9 @@ let has_explanation t3 t4 = | Tvar _, _ | Tvariant _, Tvariant _ -> true - | Tfield (l, _, _, {desc = Tnil}), Tfield (l', _, _, {desc = Tnil}) -> l = l' + | ( Tfield {name = l; rest = {desc = Tnil}}, + Tfield {name = l'; rest = {desc = Tnil}} ) -> + l = l' | _ -> false let rec mismatch = function @@ -1326,11 +1335,12 @@ let explanation unif t3 t4 ppf = else fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" type_expr t' "it would escape the scope of its equation" - | Tfield (lab, _, _, _), _ when lab = dummy_method -> + | Tfield {name = lab}, _ when lab = dummy_method -> fprintf ppf "@,Self type cannot be unified with a closed object type" - | _, Tfield (lab, _, _, _) when lab = dummy_method -> + | _, Tfield {name = lab} when lab = dummy_method -> fprintf ppf "@,Self type cannot be unified with a closed object type" - | Tfield (l, _, f1, {desc = Tnil}), Tfield (l', _, f2, {desc = Tnil}) + | ( Tfield {name = l; typ = f1; rest = {desc = Tnil}}, + Tfield {name = l'; typ = f2; rest = {desc = Tnil}} ) when l = l' -> fprintf ppf "@,\ @@ -1339,14 +1349,14 @@ let explanation unif t3 t4 ppf = Field @{\"%s\"@} in the passed object has type @{%a@}, but \ is expected to have type @{%a@}." l l type_expr f1 type_expr f2 - | (Tnil | Tconstr _), Tfield (l, _, f1, _) -> + | (Tnil | Tconstr _), Tfield {name = l; typ = f1} -> fprintf ppf "@,\ @,\ @[The first object is expected to have a field @{\"%s\"@} of type \ @{%a@}, but it does not.@]" l type_expr f1 - | Tfield (l, _, f1, _), (Tnil | Tconstr _) -> + | Tfield {name = l; typ = f1}, (Tnil | Tconstr _) -> fprintf ppf "@,\ @,\ diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index c6cb73f21e..3e36d2d3c0 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -364,9 +364,13 @@ and expression i ppf x = line i ppf "Texp_for_await_of \"%a\"\n" fmt_ident s; expression i ppf e1; expression i ppf e2 - | Texp_send (e, s) -> - line i ppf "Texp_send \"%s\"\n" s; + | Texp_object_get (e, s) -> + line i ppf "Texp_object_get \"%s\"\n" s.txt; expression i ppf e + | Texp_object_set (e, s, v) -> + line i ppf "Texp_object_set \"%s\"\n" s.txt; + expression i ppf e; + expression i ppf v | Texp_object_literal fields -> line i ppf "Texp_object_literal\n"; List.iter diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 70aefd8884..f25169dcaa 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -207,8 +207,8 @@ let rec classify_expression : Typedtree.expression -> sd = Static | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> Static - | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ - | Texp_assert _ | Texp_try _ -> + | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_object_get _ + | Texp_object_set _ | Texp_field _ | Texp_assert _ | Texp_try _ -> Dynamic let rec expression : Env.env -> Typedtree.expression -> Use.t = @@ -296,7 +296,9 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = Use.(join (discard (expression env e1)) (expression env e2)) | Texp_while (e1, e2) -> Use.(join (inspect (expression env e1)) (discard (expression env e2))) - | Texp_send (e1, _) -> Use.inspect (expression env e1) + | Texp_object_get (e1, _) -> Use.inspect (expression env e1) + | Texp_object_set (e1, _, e2) -> + Use.(join (inspect (expression env e1)) (inspect (expression env e2))) | Texp_object_literal fields -> Use.inspect (list (fun env (_, e) -> expression env e) env fields) | Texp_field (e, _, _) -> Use.(inspect (expression env e)) diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 9da527bbe3..fa969bf33d 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -34,7 +34,8 @@ let substitute_types ~type_map (t : Types.type_expr) = } | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} | Tobject t -> {t with desc = Tobject (loop t)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tfield f -> + {t with desc = Tfield {f with typ = loop f.typ; rest = loop f.rest}} | Tpoly (t, []) -> loop t | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} | Tpackage (p, l, tl) -> diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 12fd6da706..0c092bb52a 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -127,7 +127,7 @@ let norm = function let ctype_apply_env_empty = ref (fun _ -> assert false) (* Similar to [Ctype.nondep_type_rec]. *) -let rec typexp s ty = +let rec typexp_rec s ty = let ty = repr ty in match ty.desc with | (Tvar _ | Tunivar _) as desc -> @@ -140,7 +140,7 @@ let rec typexp s ty = ty') else ty | Tsubst ty -> ty - | Tfield (m, k, _t1, _t2) + | Tfield {name = m; presence = k} when (not s.for_saving) && m = dummy_method && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> @@ -171,15 +171,15 @@ let rec typexp s ty = else match desc with | Tconstr (p, args, _abbrev) -> ( - let args = List.map (typexp s) args in + let args = List.map (typexp_rec s) args in match Path_map.find p s.types with | exception Not_found -> Tconstr (type_path s p, args, ref Mnil) | Path _ -> Tconstr (type_path s p, args, ref Mnil) | Type_function {params; body} -> (!ctype_apply_env_empty params body args).desc) | Tpackage (p, n, tl) -> - Tpackage (modtype_path s p, n, List.map (typexp s) tl) - | Tobject t1 -> Tobject (typexp s t1) + Tpackage (modtype_path s p, n, List.map (typexp_rec s) tl) + | Tobject t1 -> Tobject (typexp_rec s t1) | Tvariant row -> ( let row = row_repr row in let more = repr row.row_more in @@ -203,7 +203,7 @@ let rec typexp s ty = let more' = match more.desc with | Tsubst ty -> ty - | Tconstr _ | Tnil -> typexp s more + | Tconstr _ | Tnil -> typexp_rec s more | Tunivar _ | Tvar _ -> save_desc more more.desc; if s.for_saving then newpersty (norm more.desc) @@ -214,7 +214,7 @@ let rec typexp s ty = (* Register new type first for recursion *) more.desc <- Tsubst (newgenty (Ttuple [more'; ty'])); (* Return a new copy *) - let row = copy_row (typexp s) true row (not dup) more' in + let row = copy_row (typexp_rec s) true row (not dup) more' in match row.row_name with | Some (p, tl) -> Tvariant @@ -225,72 +225,69 @@ let rec typexp s ty = else Some (type_path s p, tl)); } | None -> Tvariant row)) - | Tfield (_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> - Tlink (typexp s t2) - | _ -> copy_type_desc (typexp s) desc); + | Tfield {presence = kind; rest = t2} + when field_kind_repr kind = Fabsent -> + Tlink (typexp_rec s t2) + | _ -> copy_type_desc (typexp_rec s) desc); ty' (* Always make a copy of the type. If this is not done, type levels might not be correct. *) -let type_expr s ty = - let ty' = typexp s ty in - cleanup_types (); - ty' +let type_expr s ty = with_copy_session (fun () -> typexp_rec s ty) + +let typexp = type_expr let label_declaration s l = { ld_id = l.ld_id; ld_mutable = l.ld_mutable; ld_optional = l.ld_optional; - ld_type = typexp s l.ld_type; + ld_type = typexp_rec s l.ld_type; ld_loc = loc s l.ld_loc; ld_attributes = attrs s l.ld_attributes; } let constructor_arguments s = function - | Cstr_tuple l -> Cstr_tuple (List.map (typexp s) l) + | Cstr_tuple l -> Cstr_tuple (List.map (typexp_rec s) l) | Cstr_record l -> Cstr_record (List.map (label_declaration s) l) let constructor_declaration s c = { cd_id = c.cd_id; cd_args = constructor_arguments s c.cd_args; - cd_res = may_map (typexp s) c.cd_res; + cd_res = may_map (typexp_rec s) c.cd_res; cd_loc = loc s c.cd_loc; cd_attributes = attrs s c.cd_attributes; } let type_declaration s decl = - let decl = - { - type_params = List.map (typexp s) decl.type_params; - type_arity = decl.type_arity; - type_kind = - (match decl.type_kind with - | Type_abstract -> Type_abstract - | Type_variant (cstrs, layout) -> - Type_variant (List.map (constructor_declaration s) cstrs, layout) - | Type_record (lbls, rep) -> - Type_record (List.map (label_declaration s) lbls, rep) - | Type_open -> Type_open); - type_manifest = - (match decl.type_manifest with - | None -> None - | Some ty -> Some (typexp s ty)); - type_private = decl.type_private; - type_variance = decl.type_variance; - type_newtype_level = None; - type_loc = loc s decl.type_loc; - type_attributes = attrs s decl.type_attributes; - type_immediate = decl.type_immediate; - type_representation = decl.type_representation; - type_inlined_types = decl.type_inlined_types; - } - in - cleanup_types (); - decl + with_copy_session (fun () -> + { + type_params = List.map (typexp_rec s) decl.type_params; + type_arity = decl.type_arity; + type_kind = + (match decl.type_kind with + | Type_abstract -> Type_abstract + | Type_variant (cstrs, layout) -> + Type_variant (List.map (constructor_declaration s) cstrs, layout) + | Type_record (lbls, rep) -> + Type_record (List.map (label_declaration s) lbls, rep) + | Type_open -> Type_open); + type_manifest = + (match decl.type_manifest with + | None -> None + | Some ty -> Some (typexp_rec s ty)); + type_private = decl.type_private; + type_variance = decl.type_variance; + type_newtype_level = None; + type_loc = loc s decl.type_loc; + type_attributes = attrs s decl.type_attributes; + type_immediate = decl.type_immediate; + type_representation = decl.type_representation; + type_inlined_types = decl.type_inlined_types; + }) let value_description s descr = { @@ -301,20 +298,17 @@ let value_description s descr = } let extension_constructor s ext = - let ext = - { - ext_type_path = type_path s ext.ext_type_path; - ext_type_params = List.map (typexp s) ext.ext_type_params; - ext_args = constructor_arguments s ext.ext_args; - ext_ret_type = may_map (typexp s) ext.ext_ret_type; - ext_private = ext.ext_private; - ext_attributes = attrs s ext.ext_attributes; - ext_loc = (if s.for_saving then Location.none else ext.ext_loc); - ext_is_exception = ext.ext_is_exception; - } - in - cleanup_types (); - ext + with_copy_session (fun () -> + { + ext_type_path = type_path s ext.ext_type_path; + ext_type_params = List.map (typexp_rec s) ext.ext_type_params; + ext_args = constructor_arguments s ext.ext_args; + ext_ret_type = may_map (typexp_rec s) ext.ext_ret_type; + ext_private = ext.ext_private; + ext_attributes = attrs s ext.ext_attributes; + ext_loc = (if s.for_saving then Location.none else ext.ext_loc); + ext_is_exception = ext.ext_is_exception; + }) let rec rename_bound_idents s idents = function | [] -> (List.rev idents, s) diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 11c014bb58..a928e7dd6d 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -199,7 +199,10 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_for_await_of (_, _, exp1, exp2) -> sub.expr sub exp1; sub.expr sub exp2 - | Texp_send (exp, _) -> sub.expr sub exp + | Texp_object_get (exp, _) -> sub.expr sub exp + | Texp_object_set (exp, _, v) -> + sub.expr sub exp; + sub.expr sub v | Texp_object_literal fields -> List.iter (fun (_, e) -> sub.expr sub e) fields | Texp_letmodule (_, _, mexpr, exp) -> diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 31b79f7cef..5a765aedd4 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -253,7 +253,9 @@ let expr sub x = Texp_for_of (id, p, sub.expr sub exp1, sub.expr sub exp2) | Texp_for_await_of (id, p, exp1, exp2) -> Texp_for_await_of (id, p, sub.expr sub exp1, sub.expr sub exp2) - | Texp_send (exp, meth) -> Texp_send (sub.expr sub exp, meth) + | Texp_object_get (exp, name) -> Texp_object_get (sub.expr sub exp, name) + | Texp_object_set (exp, name, v) -> + Texp_object_set (sub.expr sub exp, name, sub.expr sub v) | Texp_object_literal fields -> Texp_object_literal (List.map (fun (s, e) -> (s, sub.expr sub e)) fields) | Texp_letmodule (id, s, mexpr, exp) -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 235d3895e9..b0dc3065a0 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1069,17 +1069,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) | Ploc _, _ -> assert false | _, _ -> wrap (Lprim (prim, argl, e.exp_loc))))) - | Texp_apply - { - funct = {exp_desc = Texp_send (obj, name)}; - args = [(Nolabel, Some value)]; - } - when Ext_string.ends_with name Literals.setter_suffix -> - let property = - String.sub name 0 (String.length name - Literals.setter_suffix_len) - in - Lprim - (Pjs_object_set property, [transl_exp obj; transl_exp value], e.exp_loc) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct @@ -1242,11 +1231,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = ( Pjs_object_create labels, List.map (fun (_, field) -> transl_exp field) fields, e.exp_loc ) - | Texp_send (expr, nm) -> - (* A setter member only ever occurs applied (recognized in the - [Texp_apply] case); a bare occurrence cannot be compiled. *) - assert (not (Ext_string.ends_with nm Literals.setter_suffix)); - Lprim (Pjs_object_get nm, [transl_exp expr], e.exp_loc) + | Texp_object_get (expr, nm) -> + Lprim (Pjs_object_get nm.txt, [transl_exp expr], e.exp_loc) + | Texp_object_set (expr, nm, value) -> + Lprim (Pjs_object_set nm.txt, [transl_exp expr; transl_exp value], e.exp_loc) | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in Llet (Strict, Pgenval, id, defining_expr, transl_exp body) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index fd97181927..c96dff42ce 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -56,6 +56,7 @@ type error = | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Undefined_method of type_expr * string * string list option + | Object_field_not_mutable of type_expr * string | Private_type of type_expr | Not_subtype of Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option @@ -186,9 +187,12 @@ let iter_expression f e = | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) | Pexp_letexception (_, e) - | Pexp_send (e, _) + | Pexp_object_get (e, _) | Pexp_field (e, _) -> expr e + | Pexp_object_set (e1, _, e2) -> + expr e1; + expr e2 | Pexp_object_literal fields -> List.iter (fun (_, e) -> expr e) fields | Pexp_while (e1, e2) | Pexp_sequence (e1, e2) | Pexp_setfield (e1, _, e2) -> @@ -2332,6 +2336,26 @@ let should_unify_expected_result_before_typing_lowered_apply funct sargs = | _ -> false type targs = (Asttypes.arg_label * Typedtree.expression option) list +let object_field_use_type env typ = + match Ctype.repr typ with + | {desc = Tpoly (ty, [])} -> instance env ty + | {desc = Tpoly (ty, tl)} -> snd (instance_poly false tl ty) + | {desc = Tvar _} as ty -> + let ty' = newvar () in + unify env (instance_def ty) (newty (Tpoly (ty', []))); + ty' + | _ -> assert false + +let object_valid_fields env ty = + match (expand_head env ty).desc with + | Tobject fields -> + let fields, _ = Ctype.flatten_fields fields in + let collect_fields li (f : Ctype.field_info) = + if f.f_kind = Fpresent then f.f_name :: li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + let rec type_exp ?deprecated_context ~context ?recarg env sexp = (* We now delegate everything to type_expect *) type_expect ?deprecated_context ~context ?recarg env sexp (newvar ()) @@ -3325,7 +3349,14 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp else ( Hashtbl.add emitted s.txt (); newty - (Tfield (s.txt, Fpresent, newty (Tpoly (field.exp_type, [])), rest)))) + (Tfield + { + name = s.txt; + presence = Fpresent; + mutability = ref (Mutability_value Asttypes.Immutable); + typ = newty (Tpoly (field.exp_type, [])); + rest; + }))) fields (newty Tnil) in rue @@ -3337,23 +3368,14 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_send (e, {txt = met}) -> ( + | Pexp_object_get (e, ({txt = met} as met_loc)) -> ( let obj = type_exp ~context:None env e in try let typ = filter_method env met Public obj.exp_type in - let typ = - match repr typ with - | {desc = Tpoly (ty, [])} -> instance env ty - | {desc = Tpoly (ty, tl)} -> snd (instance_poly false tl ty) - | {desc = Tvar _} as ty -> - let ty' = newvar () in - unify env (instance_def ty) (newty (Tpoly (ty', []))); - ty' - | _ -> assert false - in + let typ = object_field_use_type env typ in rue { - exp_desc = Texp_send (obj, met); + exp_desc = Texp_object_get (obj, met_loc); exp_loc = loc; exp_extra = []; exp_type = typ; @@ -3361,20 +3383,40 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_env = env; } with Unify _ -> - let valid_methods = - match (expand_head env obj.exp_type).desc with - | Tobject fields -> - let fields, _ = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if meth_kind = Fpresent then meth :: li else li - in - Some (List.fold_left collect_fields [] fields) - | _ -> None - in raise (Error - (e.pexp_loc, env, Undefined_method (obj.exp_type, met, valid_methods))) - ) + ( e.pexp_loc, + env, + Undefined_method + (obj.exp_type, met, object_valid_fields env obj.exp_type) ))) + | Pexp_object_set (e, ({txt = name} as name_loc), svalue) -> ( + let obj = type_exp ~context:None env e in + let field_typ = + try Ctype.filter_object_field_for_write env name obj.exp_type + with Unify _ -> Error Ctype.Owrite_missing + in + match field_typ with + | Error Owrite_missing -> + raise + (Error + ( e.pexp_loc, + env, + Undefined_method + (obj.exp_type, name, object_valid_fields env obj.exp_type) )) + | Error Owrite_not_mutable -> + raise (Error (loc, env, Object_field_not_mutable (obj.exp_type, name))) + | Ok typ -> + let typ = object_field_use_type env typ in + let value = type_expect ~context:None env svalue typ in + rue + { + exp_desc = Texp_object_set (obj, name_loc, value); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + }) | Pexp_letmodule (name, smodl, sbody) -> let ty = newvar () in (* remember original level *) @@ -5068,6 +5110,13 @@ let report_error env loc ppf error = (function | ppf -> fprintf ppf "but a %s was expected belonging to the %s type" name kind) + | Object_field_not_mutable (ty, name) -> + fprintf ppf + "@[@[This expression has type@;\ + <1 2>%a@]@,\ + The field %s is not settable. Only fields annotated with @set, e.g. \ + {@set \"%s\": int}, can be assigned.@]" + type_expr ty name name | Undefined_method (ty, me, valid_methods) -> ( fprintf ppf "@[@[This expression has type@;<1 2>%a@]@,It has no field %s@]" diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index d309463a79..42b5d4ce68 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -89,6 +89,7 @@ type error = | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Undefined_method of type_expr * string * string list option + | Object_field_not_mutable of type_expr * string | Private_type of type_expr | Not_subtype of Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index ef267b6864..bcb2e0a1d8 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1078,7 +1078,7 @@ let compute_variance env visited vari ty = tl decl.type_variance with Not_found -> List.iter (compute_variance_rec may_inv) tl) | Tobject ty -> compute_same ty - | Tfield (_, _, ty1, ty2) -> + | Tfield {typ = ty1; rest = ty2} -> compute_same ty1; compute_same ty2 | Tsubst ty -> compute_same ty @@ -2098,9 +2098,9 @@ let explain_unbound_single ppf tv ty = if rv == tv then trivial ty else explain_unbound ppf tv tl - (fun (_, _, t) -> t) - "method" - (fun (lab, _, _) -> lab ^ ": ") + (fun (f : Ctype.field_info) -> f.f_typ) + "field" + (fun (f : Ctype.field_info) -> f.f_name ^ ": ") | Tvariant row -> let row = Btype.row_repr row in if row.row_more == tv then trivial ty diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 4693945614..ad04b6f206 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -123,7 +123,8 @@ and expression_desc = * expression * direction_flag * expression - | Texp_send of expression * string + | Texp_object_get of expression * string Asttypes.loc + | Texp_object_set of expression * string Asttypes.loc * expression | Texp_object_literal of (string Asttypes.loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 60ad0448d2..ca682cc926 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -224,7 +224,8 @@ and expression_desc = * expression * direction_flag * expression - | Texp_send of expression * string + | Texp_object_get of expression * string Asttypes.loc + | Texp_object_set of expression * string Asttypes.loc * expression | Texp_object_literal of (string Asttypes.loc * expression) list | Texp_letmodule of Ident.t * string loc * module_expr * expression | Texp_letexception of extension_constructor * expression diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index 9407e22fb4..7937972c16 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -286,7 +286,10 @@ end = struct | Texp_for_await_of (_id, _, exp1, exp2) -> iter_expression exp1; iter_expression exp2 - | Texp_send (exp, _meth) -> iter_expression exp + | Texp_object_get (exp, _) -> iter_expression exp + | Texp_object_set (exp, _, v) -> + iter_expression exp; + iter_expression v | Texp_object_literal fields -> List.iter (fun (_, e) -> iter_expression e) fields | Texp_letmodule (_id, _, mexpr, exp) -> diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 018d8fbc2a..2125b82a04 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -29,7 +29,13 @@ and type_desc = | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr - | Tfield of string * field_kind * type_expr * type_expr + | Tfield of { + name: string; + presence: field_kind; + mutability: field_mutability ref; + typ: type_expr; + rest: type_expr; + } | Tnil | Tlink of type_expr | Tsubst of type_expr (* for copying *) @@ -61,6 +67,10 @@ and abbrev_memo = and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent +and field_mutability = + | Mutability_value of Asttypes.mutable_flag + | Mutability_link of field_mutability ref + module Type_ops = struct type t = type_expr let compare t1 t2 = t1.id - t2.id diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index dc5e571925..44d46651c4 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -54,7 +54,18 @@ type type_expr = {mutable desc: type_desc; mutable level: int; id: int} Whereas [type_expr] is a pure construct which allows referring to existing types. - Note on mutability: TBD. + Note on object-field mutability: each [Tfield] carries a + [field_mutability ref]. Semantically the state is two-valued + ([Immutable] or [Mutable], read through [Btype.mutability_repr]); + [Mutability_link] is pure representation — a union-find edge that makes + every field constrained to have the same mutability share one + equivalence class, so a promotion (Immutable to Mutable on an open row) + is seen by all of them at once. Classes are merged only by unification; + promotions and merges are logged on the backtracking trail; copying + duplicates a class iff the row ends in a generic variable (a scheme + instantiation) and shares it otherwise, mirroring the sharing law of + the row variable itself. Links never appear in saved (marshalled) + types. *) and arg = {lbl: arg_label; typ: type_expr} @@ -76,8 +87,16 @@ and type_desc = (** [Tobject `f1:t1;...;fn: tn'] ==> [{"f1": t1, ..., "fn": tn}] f1, fn are represented as a linked list of types using Tfield and Tnil constructors, terminated by a row variable when the row is open. *) - | Tfield of string * field_kind * type_expr * type_expr - (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) + | Tfield of { + name: string; + presence: field_kind; + mutability: field_mutability ref; + typ: type_expr; + rest: type_expr; + } + (** [Tfield {name = "foo"; presence = Fpresent; mutability; typ; rest}] + ==> [{.. "foo": typ, rest}]; [mutability] records whether the field + admits assignment ([@set]). *) | Tnil (** [Tnil] ==> [<...; >] *) | Tlink of type_expr (** Indirection used by unification engine. *) | Tsubst of type_expr (* for copying *) @@ -166,6 +185,14 @@ and abbrev_memo = and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent +(** Mutability state of an object field, shared through an equivalence class + of cells. [Mutability_link] is an internal graph edge (union by + unification, duplication memo during copying) — never a third semantic + state; the class's value is at the end of the link chain. *) +and field_mutability = + | Mutability_value of Asttypes.mutable_flag + | Mutability_link of field_mutability ref + module Type_ops : sig type t = type_expr val compare : t -> t -> int diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index b14afe6dc9..ce129a8e71 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -568,15 +568,28 @@ and transl_poly_type env policy t = and transl_fields env policy o fields = let hfields = Hashtbl.create 17 in - let add_typed_field loc l ty = + let add_typed_field loc l ty mut = try - let ty' = Hashtbl.find hfields l in + let ty', _ = Hashtbl.find hfields l in + (* When duplicate declarations of a field are collapsed, preserve + [Mutable] if any declaration has [@set]. *) + if mut = Asttypes.Mutable then + Hashtbl.replace hfields l (ty', Asttypes.Mutable); if equal env false [ty] [ty'] then () else try unify env ty ty' with Unify _trace -> raise (Error (loc, env, Method_mismatch (l, ty, ty'))) - with Not_found -> Hashtbl.add hfields l ty + with Not_found -> Hashtbl.add hfields l (ty, mut) + in + let field_mutability (attrs : Parsetree.attributes) = + if + List.exists + (fun (({txt}, payload) : Parsetree.attribute) -> + txt = "set" && payload = Parsetree.PStr []) + attrs + then Asttypes.Mutable + else Asttypes.Immutable in let add_field = function | Otag (s, a, ty1) -> @@ -585,7 +598,7 @@ and transl_fields env policy o fields = transl_poly_type env policy ty1) in let field = OTtag (s, a, ty1) in - add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; + add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type (field_mutability a); field | Oinherit sty -> ( let cty = transl_type env policy sty in @@ -600,8 +613,9 @@ and transl_fields env policy o fields = if opened_object t then raise (Error (sty.ptyp_loc, env, Opened_object nm)); let rec iter_add = function - | Tfield (s, _k, ty1, ty2) -> - add_typed_field sty.ptyp_loc s ty1; + | Tfield {name = s; mutability; typ = ty1; rest = ty2} -> + add_typed_field sty.ptyp_loc s ty1 + (Btype.mutability_repr mutability); iter_add ty2.desc | Tnil -> () | _ -> assert false @@ -613,7 +627,7 @@ and transl_fields env policy o fields = | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))) in let object_fields = List.map add_field fields in - let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in + let fields = Hashtbl.fold (fun s f l -> (s, f) :: l) hfields [] in let ty_init = match (o, policy) with | Closed, _ -> newty Tnil @@ -622,7 +636,16 @@ and transl_fields env policy o fields = in let ty = List.fold_left - (fun ty (s, ty') -> newty (Tfield (s, Fpresent, ty', ty))) + (fun ty (s, (ty', mut)) -> + newty + (Tfield + { + name = s; + presence = Fpresent; + mutability = ref (Mutability_value mut); + typ = ty'; + rest = ty; + })) ty_init fields in (ty, object_fields) diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 13d022444a..a48f800739 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -721,7 +721,9 @@ module Sexp_ast = struct [Sexp.atom "Pexp_constraint"; expression expr; core_type typexpr] | Pexp_coerce (expr, (), typexpr) -> Sexp.list [Sexp.atom "Pexp_coerce"; expression expr; core_type typexpr] - | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] + | Pexp_object_get _ -> Sexp.list [Sexp.atom "Pexp_object_get"] + | Pexp_object_set (e1, _, e2) -> + Sexp.list [Sexp.atom "Pexp_object_set"; expression e1; expression e2] | Pexp_object_literal fields -> Sexp.list [ diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 6ed5896fff..ac8aae5392 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1775,7 +1775,17 @@ and walk_expression expr t comments = attach t.leading expr2.pexp_loc leading; walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing - | Pexp_send _ -> () + | Pexp_object_get (e1, _) -> walk_expression e1 t comments + | Pexp_object_set (e1, _, e2) -> + let leading, inside, trailing = partition_by_loc comments e1.pexp_loc in + attach t.leading e1.pexp_loc leading; + walk_expression e1 t inside; + let after_lhs, rest = partition_adjacent_trailing e1.pexp_loc trailing in + attach t.trailing e1.pexp_loc after_lhs; + let before, inside, after = partition_by_loc rest e2.pexp_loc in + attach t.leading e2.pexp_loc before; + walk_expression e2 t inside; + attach t.trailing e2.pexp_loc after and walk_expr_parameter (_attrs, _argLbl, expr_opt, pattern) t comments = let leading, inside, trailing = partition_by_loc comments pattern.ppat_loc in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index c1d85198ed..e389a4b446 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -2226,21 +2226,25 @@ and parse_bracket_access p expr start_pos = let e = let ident_loc = mk_loc string_start string_end in let loc = mk_loc start_pos rbracket in - Ast_helper.Exp.send ~loc expr (Location.mkloc s ident_loc) + Ast_helper.Exp.object_get ~loc expr (Location.mkloc s ident_loc) in let e = parse_primary_expr ~operand:e p in let equal_start = p.start_pos in match p.token with - | Equal -> + | Equal -> ( Parser.next p; let equal_end = p.prev_end_pos in let rhs_expr = parse_expr p in let loc = mk_loc start_pos rhs_expr.pexp_loc.loc_end in - let operator_loc = mk_loc equal_start equal_end in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operator_loc - (Location.mkloc (Longident.Lident "#=") operator_loc)) - [(Nolabel, e); (Nolabel, rhs_expr)] + match e.Parsetree.pexp_desc with + | Parsetree.Pexp_object_get (obj, name) -> + Ast_helper.Exp.object_set ~loc obj name rhs_expr + | _ -> + Parser.err ~start_pos:equal_start ~end_pos:equal_end p + (Diagnostics.message + "The left-hand side of this assignment is not an object property \ + access."); + e) | _ -> e) | _ -> ( let access_expr = parse_constrained_or_coerced_expr p in diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index adfe76936b..2638dd84a7 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -356,10 +356,11 @@ and print_object_fields fields rest = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun (lbl, out_type) -> + (fun (lbl, mut, out_type) -> Doc.group (Doc.concat [ + (if mut then Doc.text "@set " else Doc.nil); Doc.text ("\"" ^ lbl ^ "\": "); print_out_type_doc out_type; ])) diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 5906975b74..2f311dcfce 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -102,7 +102,8 @@ let unary_expr_operand expr = pexp_desc = ( Pexp_assert _ | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_extension _ (* readability? maybe remove *) - | Pexp_object_literal _ (* ({"a": 1})["a"] *) | Pexp_match _ | Pexp_try _ + | Pexp_object_literal _ (* ({"a": 1})["a"] *) + | Pexp_object_set _ (* (o["x"] = v)["y"] *) | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 115ec6b11f..3b44878362 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -3133,6 +3133,50 @@ and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = in Doc.concat [print_attributes ~state attrs cmt_tbl; if_docs; else_doc] +and print_object_set_expr ~state (expr : Parsetree.expression) obj member rhs + cmt_tbl = + let rhs_doc = + let doc = print_expression_with_comments ~state rhs cmt_tbl in + match Parens.expr rhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let should_indent = + (not (Parsetree_viewer.is_braced_expr rhs)) + && Parsetree_viewer.is_binary_expression rhs + in + let doc = + Doc.group + (Doc.concat + [ + print_object_get_doc ~state ~expr_loc:expr.pexp_loc obj member cmt_tbl; + Doc.text " ="; + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); + ]) + in + ignore expr; + doc + +and print_object_get_doc ~state ~expr_loc parent_expr + (label : string Location.loc) cmt_tbl = + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces + | Nothing -> doc + in + ignore expr_loc; + let member = + let member_doc = print_comments (Doc.text label.txt) cmt_tbl label.loc in + Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] + in + Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) + and print_expression ~state (e : Parsetree.expression) cmt_tbl = let print_arrow e = let async, parameters, return_expr = Parsetree_viewer.fun_expr e in @@ -3875,21 +3919,10 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = let doc_expr = print_expression_with_comments ~state expr cmt_tbl in let doc_typ = print_typ_expr ~state typ cmt_tbl in Doc.concat [Doc.lparen; doc_expr; Doc.text " :> "; doc_typ; Doc.rparen] - | Pexp_send (parent_expr, label) -> - let parent_doc = - let doc = print_expression_with_comments ~state parent_expr cmt_tbl in - match Parens.unary_expr_operand parent_expr with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc parent_expr braces - | Nothing -> doc - in - let member = - let member_doc = - print_comments (Doc.text label.txt) cmt_tbl label.loc - in - Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] - in - Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) + | Pexp_object_get (parent_expr, label) -> + print_object_get_doc ~state ~expr_loc:e.pexp_loc parent_expr label cmt_tbl + | Pexp_object_set (obj, member, rhs) -> + print_object_set_expr ~state e obj member rhs cmt_tbl | Pexp_await e -> let printed_expression = print_expression_with_comments ~state e cmt_tbl @@ -4294,13 +4327,12 @@ and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = expr.pexp_loc cmt_tbl in if is_lhs then add_parens doc else doc - | Pexp_apply - { - funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}; - args = [(Nolabel, lhs); (Nolabel, rhs)]; - } -> + | Pexp_object_set (obj, member, rhs) -> let rhs_doc = print_expression_with_comments ~state rhs cmt_tbl in - let lhs_doc = print_expression_with_comments ~state lhs cmt_tbl in + let lhs_doc = + print_object_get_doc ~state ~expr_loc:expr.pexp_loc obj member + cmt_tbl + in (* TODO: unify indentation of "=" *) let should_indent = Parsetree_viewer.is_binary_expression rhs in let doc = @@ -4579,38 +4611,6 @@ and print_pexp_apply ~state expr cmt_tbl = member; Doc.rbracket; ]) - | Pexp_apply - { - funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}; - args = [(Nolabel, lhs); (Nolabel, rhs)]; - } -> ( - let rhs_doc = - let doc = print_expression_with_comments ~state rhs cmt_tbl in - match Parens.expr rhs with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let should_indent = - (not (Parsetree_viewer.is_braced_expr rhs)) - && Parsetree_viewer.is_binary_expression rhs - in - let doc = - Doc.group - (Doc.concat - [ - print_expression_with_comments ~state lhs cmt_tbl; - Doc.text " ="; - (if should_indent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) - else Doc.concat [Doc.space; rhs_doc]); - ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group (Doc.concat [print_attributes ~state attrs cmt_tbl; doc])) | Pexp_apply _ when Option.is_some (Res_parsetree_viewer.collect_spread_dict_expr_parts expr) -> ( diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index b509260a48..c6a906eeb1 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -216,6 +216,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Wrong_name` | ✓ | `wrong_name_record_field.res`, `Cross_record_extra_field` (multi) | | | `Name_type_mismatch` | ✓ | `super_errors_multi/Cross_qualified_constructor_mismatch` | Cross-module constructor disambiguation. | | `Undefined_method` | ✓ | `super_errors_multi/Cross_module_alias_dot_access`, `undefined_method` | | +| `Object_field_not_mutable` | ✓ | `object_write_closed_row`, `object_write_alias`, `object_write_after_forgetting` | Assignment to a field without `@set`; the latter two pin that promotion is per equivalence class (an alias write strengthens the shared constraint) and that a coercion never grants write capability. | | `Private_type` | ✓ | `private_type_construction.res` | | | `Private_label` | ✓ | `private_label.res` | | | `Not_subtype` | ✓ | `subtype_*.res`, `coercion_arity_mismatch.res`, `dict_show_no_coercion.res`, etc. | | diff --git a/tests/analysis_tests/tests/src/CompletionObjects.res b/tests/analysis_tests/tests/src/CompletionObjects.res index 6de39bd1a2..438c89ff83 100644 --- a/tests/analysis_tests/tests/src/CompletionObjects.res +++ b/tests/analysis_tests/tests/src/CompletionObjects.res @@ -8,3 +8,8 @@ let _ff = { | _ => "" }, } + +@val external settable: {@set "one": int, @set "two": int} = "settable" + +// settable["o"] = 1 +// ^com diff --git a/tests/analysis_tests/tests/src/expected/Completion.res.txt b/tests/analysis_tests/tests/src/expected/Completion.res.txt index 10de32c074..fd340378c3 100644 --- a/tests/analysis_tests/tests/src/expected/Completion.res.txt +++ b/tests/analysis_tests/tests/src/expected/Completion.res.txt @@ -1389,7 +1389,7 @@ Found type for function (~age: int, ~name: string) => string Complete src/Completion.res 90:13 posCursor:[90:13] posNoWhite:[90:12] Found expr:[90:3->93:18] -Pexp_send a[90:12->90:13] e:[90:3->90:10] +Pexp_object_get a[90:12->90:13] e:[90:3->90:10] Completable: Cpath Value[someObj]["a"] Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -1400,7 +1400,7 @@ Path someObj Complete src/Completion.res 95:24 posCursor:[95:24] posNoWhite:[95:23] Found expr:[95:3->99:6] -Pexp_send [95:24->95:24] e:[95:3->95:22] +Pexp_object_get [95:24->95:24] e:[95:3->95:22] Completable: Cpath Value[nestedObj]["x"]["y"][""] Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -1416,7 +1416,7 @@ Path nestedObj Complete src/Completion.res 99:7 posCursor:[99:7] posNoWhite:[99:6] Found expr:[99:3->102:20] -Pexp_send a[99:6->99:7] e:[99:3->99:4] +Pexp_object_get a[99:6->99:7] e:[99:3->99:4] Completable: Cpath Value[o]["a"] Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -1427,7 +1427,7 @@ Path o Complete src/Completion.res 104:17 posCursor:[104:17] posNoWhite:[104:16] Found expr:[104:3->125:19] -Pexp_send [104:17->104:17] e:[104:3->104:15] +Pexp_object_get [104:17->104:17] e:[104:3->104:15] Completable: Cpath Value[no]["x"]["y"][""] Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -1538,7 +1538,7 @@ Path my Complete src/Completion.res 125:19 posCursor:[125:19] posNoWhite:[125:18] Found expr:[125:3->145:32] -Pexp_send [125:19->125:19] e:[125:3->125:17] +Pexp_object_get [125:19->125:19] e:[125:3->125:17] Completable: Cpath Value[Objects, object][""] Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -1816,7 +1816,7 @@ Path sha Complete src/Completion.res 221:22 posCursor:[221:22] posNoWhite:[221:21] Found expr:[221:3->224:22] -Pexp_send [221:22->221:22] e:[221:3->221:20] +Pexp_object_get [221:22->221:22] e:[221:3->221:20] Completable: Cpath Value[FAO, forAutoObject][""] Raw opens: 2 Shadow.B.place holder ... Shadow.A.place holder Package opens Stdlib.place holder Pervasives.JsxModules.place holder @@ -2466,7 +2466,7 @@ Hover src/Completion.res 349:14 Hover src/Completion.res 352:17 Nothing at that position. Now trying to use completion. posCursor:[352:17] posNoWhite:[352:16] Found expr:[352:11->352:35] -Pexp_send age[352:30->352:33] e:[352:11->352:28] +Pexp_object_get age[352:30->352:33] e:[352:11->352:28] posCursor:[352:17] posNoWhite:[352:16] Found expr:[352:11->352:28] Pexp_ident FAO.forAutoObject:[352:11->352:28] Completable: Cpath Value[FAO, forAutoObject] @@ -2670,7 +2670,7 @@ Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:12->384:39], ...[384:39->384:40]) posCursor:[384:38] posNoWhite:[384:37] Found expr:[384:12->384:39] Pexp_apply ...__ghost__[0:-1->0:-1] (...[384:12->384:17], ...[384:19->384:39]) posCursor:[384:38] posNoWhite:[384:37] Found expr:[384:19->384:39] -Pexp_send [384:38->384:38] e:[384:19->384:36] +Pexp_object_get [384:38->384:38] e:[384:19->384:36] Completable: Cpath Value[FAO, forAutoObject][""] Raw opens: 2 Shadow.B.place holder ... Shadow.A.place holder Package opens Stdlib.place holder Pervasives.JsxModules.place holder diff --git a/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt b/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt index 9c606bd23f..1fe7a55223 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionObjects.res.txt @@ -21,3 +21,14 @@ Path x { "detail": "bool", "kind": 4, "label": "Some(false)", "tags": [] } ] +Complete src/CompletionObjects.res 13:14 +posCursor:[13:14] posNoWhite:[13:13] Found expr:[13:3->13:20] +Pexp_object_set o[13:13->13:14] e:[13:3->13:11] +Completable: Cpath Value[settable]["o"] +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[settable]["o"] +ContextPath Value[settable] +Path settable +[ { "detail": "int", "kind": 4, "label": "one", "tags": [] } ] + diff --git a/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected b/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected index 1f15ef2292..eac1500ccf 100644 --- a/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected +++ b/tests/build_tests/super_errors/expected/object_coercion_mutable_unequal.res.expected @@ -7,6 +7,8 @@ 8 │ let p = (v: {@set "x": wide}) => (v :> {@set "x": narrow}) 9 │ - Type {"x": wide, "x#=": wide => unit} is not a subtype of - {"x": narrow, "x#=": narrow => unit} - Type narrow = {"a": int} is not a subtype of wide = {"a": int, "b": int} \ No newline at end of file + Type {@set "x": wide} is not a subtype of {@set "x": narrow} + Type wide = {"a": int, "b": int} is not compatible with type + narrow = {"a": int} + + The second object is expected to have a field "b" of type int, but it does not. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected b/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected index 7d96ef7066..95d7be571b 100644 --- a/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected +++ b/tests/build_tests/super_errors/expected/object_coercion_promote_readonly_caller.res.expected @@ -8,6 +8,4 @@ 12 │ This has type: {"x": wide} - But this function argument is expecting: {.."x": wide, "x#=": wide => unit} - - The first object is expected to have a field "x#=" of type wide => unit, but it does not. \ No newline at end of file + But this function argument is expecting: {..@set "x": wide} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected b/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected index 8a305177c1..60ebf93ff4 100644 --- a/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected +++ b/tests/build_tests/super_errors/expected/object_coercion_readonly_to_mutable.res.expected @@ -7,4 +7,4 @@ 6 │ let p = (v: t) => (v :> {@set "x": int}) 7 │ - Type t = {"x": int} is not a subtype of {"x": int, "x#=": int => unit} \ No newline at end of file + Type t = {"x": int} is not a subtype of {@set "x": int} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_coercion_setter_narrower.res.expected b/tests/build_tests/super_errors/expected/object_coercion_setter_narrower.res.expected new file mode 100644 index 0000000000..9b1188cc96 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_coercion_setter_narrower.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/object_coercion_setter_narrower.res:8:32-54 + + 6 │ type wide = {"a": int, "b": int} + 7 │ type narrow = {"a": int} + 8 │ let p = (o: {.."x": wide}) => (o :> {@set "x": narrow}) + 9 │ + + Type {..@set "x": wide} is not a subtype of {@set "x": narrow} + Type wide = {"a": int, "b": int} is not compatible with type + narrow = {"a": int} + + The second object is expected to have a field "b" of type int, but it does not. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected b/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected index feb96929f8..290433e28f 100644 --- a/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected +++ b/tests/build_tests/super_errors/expected/object_open_write_readonly_caller.res.expected @@ -8,6 +8,4 @@ 9 │ This has type: {"x": int} - But this function argument is expecting: {.."x": int, "x#=": int => unit} - - The first object is expected to have a field "x#=" of type int => unit, but it does not. \ No newline at end of file + But this function argument is expecting: {..@set "x": int} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_setter_type_mismatch.res.expected b/tests/build_tests/super_errors/expected/object_setter_type_mismatch.res.expected new file mode 100644 index 0000000000..f072989842 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_setter_type_mismatch.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/object_setter_type_mismatch.res:6:12-18 + + 4 │ produced a value of declared type int that was "hello" at runtime. */ + 5 │ let breakSoundness = (o: {.."x": int}): int => { + 6 │ o["x"] = "hello" + 7 │ o["x"] + 8 │ } + + This has type: string + But it's expected to have type: int + + You can convert string to int with Int.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_after_forgetting.res.expected b/tests/build_tests/super_errors/expected/object_write_after_forgetting.res.expected new file mode 100644 index 0000000000..d5041fd415 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_after_forgetting.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/object_write_after_forgetting.res:7:3-20 + + 5 │ let writeAfterForgetting = (o: {..@set "x": int}) => { + 6 │ let forgotten = (o :> {"x": int}) + 7 │ forgotten["x"] = 2 + 8 │ } + 9 │ + + This expression has type {"x": int} + The field x is not settable. Only fields annotated with @set, e.g. {@set "x": int}, can be assigned. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected b/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected index 1a830e566b..e4bc3854d9 100644 --- a/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected +++ b/tests/build_tests/super_errors/expected/object_write_after_open_target_coercion.res.expected @@ -1,12 +1,12 @@ We've found a bug for you! - /.../fixtures/object_write_after_open_target_coercion.res:12:3 + /.../fixtures/object_write_after_open_target_coercion.res:12:3-19 10 │ let p = (v: {"x": wide}) => { 11 │ let r = (v :> {.."x": narrow}) - 12 │ r["x"] = {"a": 1} + 12 │ r["x"] = {"a": 1} 13 │ } 14 │ This expression has type {"x": narrow} - It has no field x#= \ No newline at end of file + The field x is not settable. Only fields annotated with @set, e.g. {@set "x": int}, can be assigned. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_alias.res.expected b/tests/build_tests/super_errors/expected/object_write_alias.res.expected new file mode 100644 index 0000000000..253fa5492b --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_alias.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/object_write_alias.res:13:27-34 + + 11 │ } + 12 │ + 13 │ let rejected = writeAlias(readonly) + 14 │ + + This has type: {"x": int} + But this function argument is expecting: {..@set "x": int} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected b/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected index 47f058fd0d..bf2ef07a03 100644 --- a/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected +++ b/tests/build_tests/super_errors/expected/object_write_closed_row.res.expected @@ -1,11 +1,11 @@ We've found a bug for you! - /.../fixtures/object_write_closed_row.res:6:28 + /.../fixtures/object_write_closed_row.res:6:28-37 4 │ See docs/object_representation_cleanup.md; compiling counterparts in 5 │ tests/tests/src/object_mutability_pin.res. */ - 6 │ let g = (o: {"x": int}) => o["x"] = 1 + 6 │ let g = (o: {"x": int}) => o["x"] = 1 7 │ This expression has type {"x": int} - It has no field x#= \ No newline at end of file + The field x is not settable. Only fields annotated with @set, e.g. {@set "x": int}, can be assigned. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_original_after_alias.res.expected b/tests/build_tests/super_errors/expected/object_write_original_after_alias.res.expected new file mode 100644 index 0000000000..37d98ba4f5 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_original_after_alias.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/object_write_original_after_alias.res:12:30-37 + + 10 │ } + 11 │ + 12 │ let rejected = writeOriginal(readonly) + 13 │ + + This has type: {"x": int} + But this function argument is expecting: {..@set "x": int} diff --git a/tests/build_tests/super_errors/fixtures/object_coercion_setter_narrower.res b/tests/build_tests/super_errors/fixtures/object_coercion_setter_narrower.res new file mode 100644 index 0000000000..bd364d47fe --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_coercion_setter_narrower.res @@ -0,0 +1,8 @@ +/* A coercion cannot acquire write access at a type different from the + field's type: promotion changes mutability without changing the field + type, and mutable fields are invariant. Under the previous phantom-member + encoding this compiled, leaving getter `wide` and setter `narrow` on one + property. */ +type wide = {"a": int, "b": int} +type narrow = {"a": int} +let p = (o: {.."x": wide}) => (o :> {@set "x": narrow}) diff --git a/tests/build_tests/super_errors/fixtures/object_setter_type_mismatch.res b/tests/build_tests/super_errors/fixtures/object_setter_type_mismatch.res new file mode 100644 index 0000000000..86fc246197 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_setter_type_mismatch.res @@ -0,0 +1,8 @@ +/* Assignment cannot give a field a type unrelated to its getter: writing + promotes the field (open row) and unifies the value with the field's one + type. Under the previous phantom-member encoding this compiled and + produced a value of declared type int that was "hello" at runtime. */ +let breakSoundness = (o: {.."x": int}): int => { + o["x"] = "hello" + o["x"] +} diff --git a/tests/build_tests/super_errors/fixtures/object_write_after_forgetting.res b/tests/build_tests/super_errors/fixtures/object_write_after_forgetting.res new file mode 100644 index 0000000000..fa89ca33ce --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_after_forgetting.res @@ -0,0 +1,8 @@ +/* Coercing a settable open source to a closed immutable target forgets + write capability: the coercion result is read-only. (The enlarged + approximation used by the coercion fast path has its own mutability + cells, so checking against it cannot promote the declared target.) */ +let writeAfterForgetting = (o: {..@set "x": int}) => { + let forgotten = (o :> {"x": int}) + forgotten["x"] = 2 +} diff --git a/tests/build_tests/super_errors/fixtures/object_write_alias.res b/tests/build_tests/super_errors/fixtures/object_write_alias.res new file mode 100644 index 0000000000..5746af32ad --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_alias.res @@ -0,0 +1,13 @@ +/* Writing through an ANNOTATED ALIAS strengthens the original parameter + exactly as writing through the parameter does (mutability classes are + merged by unification), so a read-only caller is rejected. The pair of + this fixture is object_write_original_after_alias.res; both forms impose + the same requirement. */ +@val external readonly: {"x": int} = "readonly" + +let writeAlias = (o: {.."x": int}) => { + let alias: {.."x": int} = o + alias["x"] = 1 +} + +let rejected = writeAlias(readonly) diff --git a/tests/build_tests/super_errors/fixtures/object_write_original_after_alias.res b/tests/build_tests/super_errors/fixtures/object_write_original_after_alias.res new file mode 100644 index 0000000000..73ae1d9492 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_original_after_alias.res @@ -0,0 +1,12 @@ +/* Writing through the ORIGINAL parameter strengthens its requirement, so a + read-only caller is rejected. Writing through an annotated alias imposes + the same requirement (mutability classes are merged by unification) — + see the paired fixture object_write_alias.res. */ +@val external readonly: {"x": int} = "readonly" + +let writeOriginal = (o: {.."x": int}) => { + let _alias: {.."x": int} = o + o["x"] = 1 +} + +let rejected = writeOriginal(readonly) diff --git a/tests/ounit_tests/ounit_object_mutability_tests.ml b/tests/ounit_tests/ounit_object_mutability_tests.ml new file mode 100644 index 0000000000..0766ea10d3 --- /dev/null +++ b/tests/ounit_tests/ounit_object_mutability_tests.ml @@ -0,0 +1,394 @@ +(* Representation-level tests for object-field mutability state: the + linkable [field_mutability] cells in [Tfield] (doc §7). These properties + are not observable from generated JavaScript, so they are tested here + directly against [Ctype]/[Btype]. + + The invariants: unification merges mutability equivalence classes + (order-independent, alias-preserving); instantiating a generalized row + duplicates each class once per instance; structure-generalized copies + share classes; promotion and links are backtrackable; saving preserves + class sharing without persisting links. *) + +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_bool = OUnit.assert_bool + +let int_typ () = Predef.type_int +let immutable_cell () = ref (Types.Mutability_value Asttypes.Immutable) +let mutable_cell () = ref (Types.Mutability_value Asttypes.Mutable) + +(* An object row [{"x": int, ..}] whose field uses the given mutability + cell; open (fresh row var) unless [closed]. *) +let obj_with_cell ?(closed = false) cell = + let rest = if closed then Ctype.newty Types.Tnil else Ctype.newvar () in + Ctype.newobj + (Ctype.newty + (Types.Tfield + { + name = "x"; + presence = Types.Fpresent; + mutability = cell; + typ = int_typ (); + rest; + })) + +let field_of ty = + match Ctype.flatten_fields (Ctype.object_fields ty) with + | [f], _ -> f + | _ -> OUnit.assert_failure "expected exactly one field" + +let flag_of ty = Btype.mutability_repr (field_of ty).Ctype.f_mut + +(* Class identity: the terminal cell of the link chain. *) +let cell_of ty = Btype.mutability_ref_repr (field_of ty).Ctype.f_mut + +let write_through ty = + (* Simulate [ty["x"] = v]: the promotion path used by assignment. *) + match Ctype.filter_object_field_for_write Env.empty "x" ty with + | Ok _ -> () + | Error _ -> OUnit.assert_failure "write lookup unexpectedly failed" + +(* Two views sharing one cell (an alias group), a third object with its own + cell. Returns (group_member_a, group_member_b, other). *) +let alias_setup () = + let group_cell = immutable_cell () in + let a = obj_with_cell group_cell in + let b = obj_with_cell group_cell in + let other = obj_with_cell (immutable_cell ()) in + (a, b, other) + +let test_unification_merges_alias_groups _ = + let a, b, other = alias_setup () in + Ctype.unify Env.empty other a; + write_through other; + assert_bool "promotion through the unified view reaches the direct alias" + (flag_of a = Asttypes.Mutable); + assert_bool + "promotion also reaches the other member of the merged class: unification \ + merges groups, it does not splice single nodes" + (flag_of b = Asttypes.Mutable) + +let test_unification_order_is_irrelevant _ = + let a1, b1, other1 = alias_setup () in + Ctype.unify Env.empty other1 a1; + write_through other1; + ignore a1; + let promoted_order1 = flag_of b1 = Asttypes.Mutable in + let a2, b2, other2 = alias_setup () in + Ctype.unify Env.empty a2 other2; + write_through other2; + ignore a2; + let promoted_order2 = flag_of b2 = Asttypes.Mutable in + assert_bool "the merged class sees the promotion in either argument order" + (promoted_order1 && promoted_order2) + +let test_backtracking_restores_promotion_and_links _ = + let source = obj_with_cell (immutable_cell ()) in + let target = obj_with_cell ~closed:true (mutable_cell ()) in + let source_cell_before = cell_of source in + let target_cell_before = cell_of target in + let snap = Btype.snapshot () in + (* Immutable+open vs Mutable: promotes the source class, then merges the + classes. *) + Ctype.unify Env.empty source target; + assert_bool "promotion happened inside the trial" + (flag_of source = Asttypes.Mutable); + assert_bool "the classes are merged inside the trial" + (cell_of source == cell_of target); + Btype.backtrack snap; + assert_bool "backtracking undoes the promotion" + (flag_of source = Asttypes.Immutable); + assert_bool "backtracking undoes the class merge" + (cell_of target != cell_of source); + assert_bool "the separated classes keep their own values" + (cell_of source == source_cell_before + && cell_of target == target_cell_before + && flag_of target = Asttypes.Mutable) + +let test_generalized_instances_are_independent _ = + (* A let-polymorphic scheme (generic row terminator): each instance must + promote independently, and never the scheme. *) + Ctype.begin_def (); + let scheme = obj_with_cell (immutable_cell ()) in + Ctype.end_def (); + Ctype.generalize scheme; + let inst1 = Ctype.instance Env.empty scheme in + let inst2 = Ctype.instance Env.empty scheme in + write_through inst1; + assert_bool "promoted instance is Mutable" (flag_of inst1 = Asttypes.Mutable); + assert_bool "sibling instance stays Immutable" + (flag_of inst2 = Asttypes.Immutable); + assert_bool "the scheme itself stays Immutable" + (flag_of scheme = Asttypes.Immutable) + +let test_generalized_instance_preserves_internal_aliasing _ = + (* Two fields of one scheme sharing a class: one instantiation must give + both fields ONE fresh class (aliases stay correlated inside the + instance), not one class each. *) + Ctype.begin_def (); + let cell = immutable_cell () in + let a = obj_with_cell cell in + let b = obj_with_cell cell in + let pair = Ctype.newty (Types.Ttuple [a; b]) in + Ctype.end_def (); + Ctype.generalize pair; + let inst = Ctype.instance Env.empty pair in + let a', b' = + match (Btype.repr inst).desc with + | Types.Ttuple [a'; b'] -> (a', b') + | _ -> OUnit.assert_failure "expected an instantiated pair" + in + assert_bool "the instance's aliases share one fresh class" + (cell_of a' == cell_of b'); + assert_bool "the fresh class is not the scheme's" + (cell_of a' != Btype.mutability_ref_repr cell) + +let test_structure_generalized_occurrences_share _ = + (* A parameter-annotation-like type: structure is generalized but the row + terminator stays at the current level, so occurrences (instances) share + the class and a promotion is visible through all of them. *) + let annotated = obj_with_cell (immutable_cell ()) in + Ctype.generalize_structure annotated; + let occurrence1 = Ctype.instance Env.empty annotated in + let occurrence2 = Ctype.instance Env.empty annotated in + write_through occurrence1; + assert_bool "promotion is visible through the other occurrence" + (flag_of occurrence2 = Asttypes.Mutable); + assert_bool "promotion is visible through the annotation itself" + (flag_of annotated = Asttypes.Mutable) + +(* ---- §7.4 Q1: every path that shares a mutability class between two + owners also shares the row terminator node, so terminator genericity is + a property of the sharing class and the copy policy is well defined. *) + +let terminator_of ty = + let _, rest = Ctype.flatten_fields (Ctype.object_fields ty) in + Btype.repr rest + +let abstract_type_decl type_manifest : Types.type_declaration = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_representation = Boxed; + type_inlined_types = []; + } + +let test_q1_unified_owners_share_terminator _ = + let a = obj_with_cell (immutable_cell ()) in + let b = obj_with_cell ~closed:true (immutable_cell ()) in + Ctype.unify Env.empty a b; + assert_bool "unification makes both rows end at the same terminator node" + (terminator_of a == terminator_of b) + +let test_q1_shared_copy_shares_terminator _ = + let annotated = obj_with_cell (immutable_cell ()) in + Ctype.generalize_structure annotated; + let occurrence = Ctype.instance Env.empty annotated in + assert_bool "class shared" (cell_of occurrence == cell_of annotated); + assert_bool "terminator shared" + (terminator_of occurrence == terminator_of annotated) + +let test_q1_generalized_instance_fresh_cell_fresh_terminator _ = + Ctype.begin_def (); + let scheme = obj_with_cell (immutable_cell ()) in + Ctype.end_def (); + Ctype.generalize scheme; + let inst = Ctype.instance Env.empty scheme in + assert_bool "class fresh" (cell_of inst != cell_of scheme); + assert_bool "terminator fresh" (terminator_of inst != terminator_of scheme) + +let test_q1_subst_generic_copy_gets_fresh_cell _ = + Ctype.begin_def (); + let scheme = obj_with_cell (immutable_cell ()) in + Ctype.end_def (); + Ctype.generalize scheme; + let copy = Subst.type_expr Subst.identity scheme in + assert_bool "subst of a generic row refreshes the class" + (cell_of copy != cell_of scheme) + +let test_nondep_type_ends_its_copy_session _ = + (* [nondep_type] copies through [copy_type_desc], whose cell duplication + temporarily links originals to their duplicates; the nondep entry + points must end that session. + A leaked session would leave the scheme's representative linked and + let a later unrelated copy session restore stale values. *) + Ctype.begin_def (); + let scheme = obj_with_cell (immutable_cell ()) in + Ctype.end_def (); + Ctype.generalize scheme; + let copy = Ctype.nondep_type Env.empty (Ident.create "M") scheme in + assert_bool "after nondep_type the scheme's cell is a direct value again" + (match !((field_of scheme).Ctype.f_mut) with + | Types.Mutability_value _ -> true + | Types.Mutability_link _ -> false); + assert_bool "the nondep copy has its own class" + (cell_of copy != cell_of scheme); + let source_inst = Ctype.instance Env.empty scheme in + write_through source_inst; + let copy_inst = Ctype.instance Env.empty copy in + assert_bool "promoting a source instance does not reach the nondep copy" + (flag_of copy_inst = Asttypes.Immutable && flag_of copy = Asttypes.Immutable); + write_through copy_inst; + ignore (Ctype.instance Env.empty scheme); + assert_bool "a subsequent unrelated copy session undoes no promotion" + (flag_of source_inst = Asttypes.Mutable + && flag_of copy_inst = Asttypes.Mutable + && flag_of scheme = Asttypes.Immutable + && flag_of copy = Asttypes.Immutable) + +let test_nondep_nested_copy_preserves_class_sharing _ = + let alias_id = Ident.create "m" in + let alias_decl = abstract_type_decl (Some Predef.type_int) in + let env = Env.add_type ~check:false alias_id alias_decl Env.empty in + Ctype.begin_def (); + let cell = immutable_cell () in + let first = obj_with_cell cell in + let dependent_alias = + Ctype.newty (Types.Tconstr (Path.Pident alias_id, [], ref Types.Mnil)) + in + let second = obj_with_cell cell in + let scheme = Ctype.newty (Types.Ttuple [first; dependent_alias; second]) in + Ctype.end_def (); + Ctype.generalize scheme; + let copy = Ctype.nondep_type env alias_id scheme in + let first', second' = + match (Btype.repr copy).desc with + | Types.Ttuple [first'; _expanded_alias; second'] -> (first', second') + | _ -> OUnit.assert_failure "expected a copied triple" + in + assert_bool + "nested abbreviation instantiation does not end the outer copy session" + (cell_of first' == cell_of second') + +let test_nondep_failure_ends_copy_session _ = + let alias_id = Ident.create "m" in + let env = + Env.add_type ~check:false alias_id (abstract_type_decl None) Env.empty + in + Ctype.begin_def (); + let cell = immutable_cell () in + let first = obj_with_cell cell in + let dependent_alias = + Ctype.newty (Types.Tconstr (Path.Pident alias_id, [], ref Types.Mnil)) + in + let scheme = Ctype.newty (Types.Ttuple [first; dependent_alias]) in + Ctype.end_def (); + Ctype.generalize scheme; + assert_bool "the dependent abstract type cannot be removed" + (match Ctype.nondep_type env alias_id scheme with + | _ -> false + | exception Not_found -> true); + assert_bool "the failed copy restored its temporary mutability link" + (match !((field_of first).Ctype.f_mut) with + | Types.Mutability_value Asttypes.Immutable -> true + | Types.Mutability_value Asttypes.Mutable | Types.Mutability_link _ -> false) + +let test_saving_closed_row_resolves_links _ = + (* Closed rows have no generic terminator, so saving shares the source's + cell rather than duplicating it (safe: marshalling deep-copies). The + shared cell must be the resolved representative — saved graphs never + contain [Mutability_link], even when the source field's own ref is a + link left by an earlier class merge. *) + let rep = immutable_cell () in + let a = obj_with_cell ~closed:true (ref (Types.Mutability_link rep)) in + assert_bool "the source field holds a link (a merged class member)" + (match !((field_of a).Ctype.f_mut) with + | Types.Mutability_link _ -> true + | Types.Mutability_value _ -> false); + let saved = Subst.type_expr (Subst.for_saving Subst.identity) a in + assert_bool "the saved field holds a value cell, not a link" + (match !((field_of saved).Ctype.f_mut) with + | Types.Mutability_value _ -> true + | Types.Mutability_link _ -> false); + assert_bool "the saved flag is the class value" + (flag_of saved = Asttypes.Immutable) + +let test_saving_marshal_round_trip _ = + (* The real persistence claim: after [for_saving] the graph marshals, and + unmarshalling preserves both the flags and the sharing relation. *) + let cell = immutable_cell () in + Ctype.begin_def (); + let pair = + Ctype.newty (Types.Ttuple [obj_with_cell cell; obj_with_cell cell]) + in + Ctype.end_def (); + Ctype.generalize pair; + let saved = Subst.type_expr (Subst.for_saving Subst.identity) pair in + let reloaded : Types.type_expr = + Marshal.from_string (Marshal.to_string saved []) 0 + in + let a', b' = + match (Btype.repr reloaded).desc with + | Types.Ttuple [a'; b'] -> (a', b') + | _ -> OUnit.assert_failure "expected a reloaded pair" + in + assert_bool "reloaded flags are values with the saved state" + (flag_of a' = Asttypes.Immutable && flag_of b' = Asttypes.Immutable); + assert_bool "reloaded spines still share one cell" (cell_of a' == cell_of b') + +let test_saving_preserves_class_sharing _ = + (* R6: saving removes links but keeps the sharing relation — two spines + sharing one class still share one (fresh, link-free) cell after + [for_saving]. *) + let cell = immutable_cell () in + Ctype.begin_def (); + let a = obj_with_cell cell in + let b = obj_with_cell cell in + let pair = Ctype.newty (Types.Ttuple [a; b]) in + Ctype.end_def (); + Ctype.generalize pair; + let saved = Subst.type_expr (Subst.for_saving Subst.identity) pair in + let a', b' = + match (Btype.repr saved).desc with + | Types.Ttuple [a'; b'] -> (a', b') + | _ -> OUnit.assert_failure "expected a saved pair" + in + assert_bool "saved spines still share one mutability cell" + (cell_of a' == cell_of b'); + assert_bool "the saved cell holds a value, not a link" + (match !((field_of a').Ctype.f_mut) with + | Types.Mutability_value _ -> true + | Types.Mutability_link _ -> false) + +let suites = + __FILE__ + >::: [ + "unification_merges_alias_groups" + >:: test_unification_merges_alias_groups; + "unification_order_is_irrelevant" + >:: test_unification_order_is_irrelevant; + "backtracking_restores_promotion_and_links" + >:: test_backtracking_restores_promotion_and_links; + "generalized_instances_are_independent" + >:: test_generalized_instances_are_independent; + "generalized_instance_preserves_internal_aliasing" + >:: test_generalized_instance_preserves_internal_aliasing; + "structure_generalized_occurrences_share" + >:: test_structure_generalized_occurrences_share; + "q1_unified_owners_share_terminator" + >:: test_q1_unified_owners_share_terminator; + "q1_shared_copy_shares_terminator" + >:: test_q1_shared_copy_shares_terminator; + "q1_generalized_instance_fresh_cell_fresh_terminator" + >:: test_q1_generalized_instance_fresh_cell_fresh_terminator; + "q1_subst_generic_copy_gets_fresh_cell" + >:: test_q1_subst_generic_copy_gets_fresh_cell; + "nondep_type_ends_its_copy_session" + >:: test_nondep_type_ends_its_copy_session; + "nondep_nested_copy_preserves_class_sharing" + >:: test_nondep_nested_copy_preserves_class_sharing; + "nondep_failure_ends_copy_session" + >:: test_nondep_failure_ends_copy_session; + "saving_closed_row_resolves_links" + >:: test_saving_closed_row_resolves_links; + "saving_marshal_round_trip" >:: test_saving_marshal_round_trip; + "saving_preserves_class_sharing" + >:: test_saving_preserves_class_sharing; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index e5dd025231..4573f83582 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -20,6 +20,7 @@ let suites = Ounit_util_tests.suites; Ounit_rec_check_tests.suites; Ounit_ast_mapper0_tests.suites; + Ounit_object_mutability_tests.suites; Ounit_pattern_printer_tests.suites; Ounit_js_analyzer_tests.suites; Ounit_flow_parser_tests.suites; diff --git a/tests/syntax_tests/data/parsing/errors/other/expected/breadcrumbs170.res.txt b/tests/syntax_tests/data/parsing/errors/other/expected/breadcrumbs170.res.txt index f0b84f86ae..a56c2bb042 100644 --- a/tests/syntax_tests/data/parsing/errors/other/expected/breadcrumbs170.res.txt +++ b/tests/syntax_tests/data/parsing/errors/other/expected/breadcrumbs170.res.txt @@ -11,7 +11,7 @@ I'm not sure what to parse here when looking at "}". let l = (Some [1; 2; 3]) -> Obj.magic -module M = struct ;;match l with | None -> [] | Some l -> l#prop end +module M = struct ;;match l with | None -> [] | Some l -> l["prop"] end ;;from ;;now ;;on diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt index b4eb70195f..b288bdd224 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt @@ -114,19 +114,19 @@ let icon = | _ -> {js|sound-max|js}) [@res.braces ]) /> let _ = - + [@res.ternary ]) key=(node["legacy_attachment_id"]) /> let _ = let _ = let _ = let x =
let _ =
-;;foo#bar #= +;;foo["bar"] = ;;foo #= ;;foo #= let x = [|
|] @@ -236,10 +236,10 @@ let _ = [@res.template ]) -> React.string) [@res.braces ])
let _ = - ((let uri = - {js|/images/header-background.png|js} in - ) + ((let uri = + {js|/images/header-background.png|js} in + ) [@res.braces ]) ;;
(((((possibleGradeValues -> (List.filter (fun [arity:1]g -> g <= state.maxGrade))) diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/primary.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/primary.res.txt index b825a969be..2a226305cb 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/primary.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/primary.res.txt @@ -21,9 +21,9 @@ let x = (arr.((x : int))).((y : int)) ;;f ~a ~b:bArg ?c ?d:expr ;;((f ~a ~b:bArg ?c ?d:expr) ~a ~b:bArg ?c ?d:expr) ~a ~b:bArg ?c ?d:expr ;;f ~a:(x : int) ?b:(y : int) -;;connection#platformId -;;((connection#left)#account)#accountName -;;john#age #= 99 -;;(john#son)#age #= (steve#age - 5) -;;dict#\n #= abc -;;dict#\" #= dict2#\" \ No newline at end of file +;;connection["platformId"] +;;((connection["left"])["account"])["accountName"] +;;john["age"] = 99 +;;(john["son"])["age"] = steve["age"] - 5 +;;dict["\n"] = abc +;;dict["\""] = dict2["\""] \ No newline at end of file diff --git a/tests/syntax_tests/data/printer/expr/expected/jsObjectSet.res.txt b/tests/syntax_tests/data/printer/expr/expected/jsObjectSet.res.txt index 1b62e7b5b5..e102767eaa 100644 --- a/tests/syntax_tests/data/printer/expr/expected/jsObjectSet.res.txt +++ b/tests/syntax_tests/data/printer/expr/expected/jsObjectSet.res.txt @@ -4,3 +4,5 @@ address["street"] = newYork->getExpensiveStreet let () = @attr address["street"] = "Brusselsestraat" let () = node["left"] = value->process->node["right"] = value->process let () = (node["left"] = value->process)->node["right"] = value->process + +let f = (o, v) => (o["x"] = v)["y"] diff --git a/tests/syntax_tests/data/printer/expr/jsObjectSet.res b/tests/syntax_tests/data/printer/expr/jsObjectSet.res index 1b62e7b5b5..e102767eaa 100644 --- a/tests/syntax_tests/data/printer/expr/jsObjectSet.res +++ b/tests/syntax_tests/data/printer/expr/jsObjectSet.res @@ -4,3 +4,5 @@ address["street"] = newYork->getExpensiveStreet let () = @attr address["street"] = "Brusselsestraat" let () = node["left"] = value->process->node["right"] = value->process let () = (node["left"] = value->process)->node["right"] = value->process + +let f = (o, v) => (o["x"] = v)["y"] diff --git a/tests/tests/src/chain_code_test.mjs b/tests/tests/src/chain_code_test.mjs index b92af8fab4..a3ff67839e 100644 --- a/tests/tests/src/chain_code_test.mjs +++ b/tests/tests/src/chain_code_test.mjs @@ -20,7 +20,7 @@ function f4(h, x, y) { x, y ]; - h.paint.draw = [ + h.brush.draw = [ x, y ]; diff --git a/tests/tests/src/chain_code_test.res b/tests/tests/src/chain_code_test.res index 8d91201bac..43001ddbc2 100644 --- a/tests/tests/src/chain_code_test.res +++ b/tests/tests/src/chain_code_test.res @@ -9,7 +9,7 @@ let f3 = (h, x, y) => h["paint"](x, y)["draw"](x, y) let f4 = (h, x, y) => { h["paint"] = (x, y) - h["paint"]["draw"] = (x, y) + h["brush"]["draw"] = (x, y) } /* let g h = */ diff --git a/tests/tests/src/object_mutability_pin.mjs b/tests/tests/src/object_mutability_pin.mjs index 6b19aba79d..0fe2234126 100644 --- a/tests/tests/src/object_mutability_pin.mjs +++ b/tests/tests/src/object_mutability_pin.mjs @@ -33,17 +33,20 @@ function read_from_readonly() { return readonlyObj.x; } -function open_source_setter_narrower(o) { - return o; +function set_x(o, v) { + o.x = v; +} + +function set_at_int() { + intTarget.x = 1; } -function unrelated_setter_type(o) { - o.x = "hello"; - return o.x; +function set_at_string() { + stringTarget.x = "s"; } -function run_unrelated_setter() { - return unrelated_setter_type(plainIntObj); +function closed_immutable_covariant(v) { + return v; } export { @@ -55,8 +58,9 @@ export { read_x, read_from_settable, read_from_readonly, - open_source_setter_narrower, - unrelated_setter_type, - run_unrelated_setter, + set_x, + set_at_int, + set_at_string, + closed_immutable_covariant, } /* No side effect */ diff --git a/tests/tests/src/object_mutability_pin.res b/tests/tests/src/object_mutability_pin.res index 97a15cf900..d3ad46cd8d 100644 --- a/tests/tests/src/object_mutability_pin.res +++ b/tests/tests/src/object_mutability_pin.res @@ -1,11 +1,11 @@ -/* Pins the current typing behavior of object-field mutability (encoded today - as phantom `"x#="` setter members) ahead of the representation cleanup - described in docs/object_representation_cleanup.md. +/* Pins the typing behavior of object-field mutability + (docs/object_representation_cleanup.md). - Every case in this file compiles today. The ones marked EXPECTED TO FLIP - are intentionally rejected by the new model (single storage location: a - field has one type; promotion only adds write capability, it never - changes the type). The others must keep compiling unchanged. + Every case in this file must keep compiling. The two cases that the + cleanup intentionally flipped to errors (a setter acquired at a type + different from the getter, via coercion or assignment) are pinned as + super_errors fixtures instead: object_coercion_setter_narrower.res and + object_setter_type_mismatch.res. The rejecting counterparts are pinned in tests/build_tests/super_errors/fixtures/object_*.res. */ @@ -46,34 +46,15 @@ let read_x = obj => obj["x"] let read_from_settable = (): wide => read_x(settable_obj) let read_from_readonly = (): wide => read_x(readonly_obj) -/* EXPECTED TO FLIP: today an open row can acquire a setter at a DIFFERENT - type than its getter, because writability is a separate member — this - coercion leaves getter type `wide` and setter type `narrow` on one - property. The new model is capability-only (Immutable A -> Mutable A, - then A = B required), so this becomes a compile error when the cleanup's - Stage D lands. */ -let open_source_setter_narrower = (o: {.."x": wide}): {@set "x": narrow} => - (o :> {@set "x": narrow}) +/* A generalized setter's instances are independent: each call site can + promote at its own field type. */ +let set_x = (o, v) => o["x"] = v -/* EXPECTED TO FLIP (unsoundness, the strongest case). +@val external int_target: {@set "x": int} = "intTarget" +@val external string_target: {@set "x": string} = "stringTarget" - Today this whole block compiles, and `run_unrelated_setter()` returns - "hello" at declared type `int` when `plain_int_obj` is the plain JS - object {x: 1}. +let set_at_int = () => set_x(int_target, 1) +let set_at_string = () => set_x(string_target, "s") - Mechanism: writability is a separate row member, so the assignment mints - "x#=": string => unit in o's open row from the right-hand side's type, - never relating it to the getter "x": int. The inferred demand is - {.."x": int, "x#=": string => unit} — but both members compile to the - same storage `o.x`, so the write invalidates the getter's type. - - New model: the assignment promotes the field to `Mutable int`, and - assigning a `string` is a unification error — the flip enforces the - getter/setter consistency invariant that is missing today. */ -let unrelated_setter_type = (o: {.."x": int}): int => { - o["x"] = "hello" - o["x"] -} - -@val external plain_int_obj: {.."x": int} = "plainIntObj" -let run_unrelated_setter = (): int => unrelated_setter_type(plain_int_obj) +/* Closed immutable-to-immutable coercion is covariant (matrix pin). */ +let closed_immutable_covariant = (v: {"x": wide}): {"x": narrow} => (v :> {"x": narrow}) From e10bfc2bea852c3eb87ecf22bbdebc3c1fcd8917 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 28 Aug 2026 15:06:02 +0200 Subject: [PATCH 07/13] Remove the object field_kind machinery (Stage E) A construction survey showed the presence lattice was dead: Fvar had a single origin - the Private branch of filter_method_field - and filter_method's only caller passed the literal Public; Fabsent was set only in the Tfield-vs-Tnil unification arm behind an Fvar guard, making it transitively unreachable (settling the reachability question deferred by the design). A probe confirmed the missing-field error against a closed row is byte-identical with the arm removed: the Fpresent path was already unconditional failure. Tfield loses its presence field and the field_kind type is deleted, along with everything that existed to serve it: field_kind_repr, copy_kind, dup_kind, set_kind, the Ckind trail constructor, the kind copy-session state, unify_kind/moregen_kind/eqtype_kind/mcomp_kind, filter_method's private_flag parameter, copy's Tfield special arm, repr's Fabsent-skip arms, and the dummy_method sentinel (unconstructed since Stage A) with its dead guards in ctype, subst, and printtyp. The companion Stage E candidate - dropping the Tpoly wrapper on object field types - is rejected after the same survey: polymorphic object fields ({"f": 'a. 'a => 'a}) are a live surface feature (the parser reads field types with parse_poly_type_expr), so Tpoly must stay, and unwrapping only the empty binder would trade the uniform "field type is Tvar or Tpoly" invariant for a mixed one. The feature, previously untested, is now pinned: object_poly_field.res/.resi cover use at two types, width subtyping, open-row access, a raw JS value, and signature inclusion over Tpoly fields; the object_literal_for_poly_field fixture pins that a monomorphic literal cannot satisfy a polymorphic field (universal-variable escape), whose disappearance would signal an unsoundness. Magics: cmi Caml1999I029, cmt Caml1999T030. Stage E of the object-representation cleanup (#8584). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- compiler/ext/config.ml | 4 +- compiler/ml/btype.ml | 61 ++------ compiler/ml/btype.mli | 10 -- compiler/ml/ctype.ml | 132 +++--------------- compiler/ml/ctype.mli | 3 +- compiler/ml/printtyp.ml | 56 ++------ compiler/ml/subst.ml | 9 -- compiler/ml/typecore.ml | 7 +- compiler/ml/types.ml | 3 - compiler/ml/types.mli | 5 +- compiler/ml/typetexp.ml | 1 - tests/ERROR_VARIANTS.md | 2 +- ...object_literal_for_poly_field.res.expected | 12 ++ .../object_literal_for_poly_field.res | 5 + .../ounit_object_mutability_tests.ml | 9 +- tests/tests/src/object_poly_field.mjs | 33 +++++ tests/tests/src/object_poly_field.res | 21 +++ tests/tests/src/object_poly_field.resi | 10 ++ 18 files changed, 125 insertions(+), 258 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/object_literal_for_poly_field.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_literal_for_poly_field.res create mode 100644 tests/tests/src/object_poly_field.mjs create mode 100644 tests/tests/src/object_poly_field.res create mode 100644 tests/tests/src/object_poly_field.resi diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 9ad1d9dfea..a7eeaffaaf 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I028" +let cmi_magic_number = "Caml1999I029" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T029" +and cmt_magic_number = "Caml1999T030" let load_path = ref ([] : string list) diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 2cef2413c7..b420fc46b2 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -68,7 +68,6 @@ let is_Tconstr = function | {desc = Tconstr _} -> true | _ -> false -let dummy_method = "*dummy method*" let default_mty = function | Some mty -> mty | None -> Mty_signature [] @@ -82,7 +81,6 @@ type change = | Cname of (Path.t * type_expr list) option ref * (Path.t * type_expr list) option | Crow of row_field option ref * row_field option - | Ckind of field_kind option ref * field_kind option | Cmutability of field_mutability ref * field_mutability | Cuniv of type_expr option ref * type_expr option | Ctypeset of Type_set.t ref * Type_set.t @@ -101,15 +99,8 @@ let log_change ch = (**** Representative of a type ****) -let rec field_kind_repr = function - | Fvar {contents = Some kind} -> field_kind_repr kind - | kind -> kind - let rec repr_link compress t d = function | {desc = Tlink t' as d'} -> repr_link true t d' t' - | {desc = Tfield {presence = k; rest = t'} as d'} - when field_kind_repr k = Fabsent -> - repr_link true t d' t' | t' -> if compress then ( log_change (Ccompress (t, t.desc, d)); @@ -119,8 +110,6 @@ let rec repr_link compress t d = function let repr t = match t.desc with | Tlink t' as d -> repr_link false t d t' - | Tfield {presence = k; rest = t'} as d when field_kind_repr k = Fabsent -> - repr_link false t d t' | _ -> t let rec row_field_repr_aux tl = function @@ -398,12 +387,6 @@ let copy_row f fixed row keep more = row_name = name; } -let rec copy_kind = function - | Fvar {contents = Some k} -> copy_kind k - | Fvar _ -> Fvar (ref None) - | Fpresent -> Fpresent - | Fabsent -> assert false - (* Since univars may be used as row variables, we need to do some encoding during substitution *) let rec norm_univar ty = @@ -426,8 +409,6 @@ let mutability_repr r = type type_copy_session = { mutable saved_desc: (type_expr * type_desc) list; - mutable saved_kinds: field_kind option ref list; - mutable new_kinds: field_kind option ref list; mutable saved_mutabilities: (field_mutability ref * field_mutability) list; mutable new_mutabilities: field_mutability ref list; mutable copy_policy_memo: (int, bool) Hashtbl.t option; @@ -439,8 +420,6 @@ let begin_type_copy_session () = type_copy_sessions := { saved_desc = []; - saved_kinds = []; - new_kinds = []; saved_mutabilities = []; new_mutabilities = []; copy_policy_memo = None; @@ -456,7 +435,6 @@ let end_type_copy_session () = match !type_copy_sessions with | session :: rest -> List.iter (fun (ty, desc) -> ty.desc <- desc) session.saved_desc; - List.iter (fun r -> r := None) session.saved_kinds; List.iter (fun (r, v) -> r := v) session.saved_mutabilities; type_copy_sessions := rest | [] -> assert false @@ -464,7 +442,7 @@ let end_type_copy_session () = (* Duplicate a mutability cell for the current copy session: the original representative is temporarily linked to the duplicate, so every field copied in this session that shares the cell reaches the same duplicate - (the [dup_kind] idiom); [cleanup_types] restores the originals. *) + (the former [dup_kind] idiom); [cleanup_types] restores the originals. *) let dup_mutability r = let session = current_type_copy_session () in let r = mutability_ref_repr r in @@ -520,25 +498,17 @@ let rec copy_type_desc ?(keep_names = false) f = function | Tobject ty -> Tobject (f ty) | Tvariant _ -> assert false (* too ambiguous *) | Tfield f_ -> - (* The presence kind is kept shared. The mutability cell follows the - row variable's sharing law: instantiating a generalized row (generic - terminator) duplicates each cell once per session via - [dup_mutability], so aliases within the instance stay correlated - while the scheme and sibling instances are untouched; other copies - hold the shared representative, so promotions reach every - occurrence. *) + (* The mutability cell follows the row variable's sharing law: + instantiating a generalized row (generic terminator) duplicates each + cell once per session via [dup_mutability], so aliases within the + instance stay correlated while the scheme and sibling instances are + untouched; other copies hold the shared representative, so + promotions reach every occurrence. *) let mutability = if row_terminator_generic f_.rest then dup_mutability f_.mutability else mutability_ref_repr f_.mutability in - Tfield - { - f_ with - presence = field_kind_repr f_.presence; - mutability; - typ = f f_.typ; - rest = f f_.rest; - } + Tfield {f_ with mutability; typ = f f_.typ; rest = f f_.rest} | Tnil -> Tnil | Tlink ty -> copy_type_desc f ty.desc | Tsubst _ -> assert false @@ -554,17 +524,6 @@ let save_desc ty desc = let session = current_type_copy_session () in session.saved_desc <- (ty, desc) :: session.saved_desc -let dup_kind r = - let session = current_type_copy_session () in - (match !r with - | None -> () - | Some _ -> assert false); - if not (List.memq r session.new_kinds) then ( - session.saved_kinds <- r :: session.saved_kinds; - let r' = ref None in - session.new_kinds <- r' :: session.new_kinds; - r := Some (Fvar r')) - (* Restored type descriptions. *) let cleanup_types () = end_type_copy_session () @@ -733,7 +692,6 @@ let undo_change = function | Clevel (ty, level) -> ty.level <- level | Cname (r, v) -> r := v | Crow (r, v) -> r := v - | Ckind (r, v) -> r := v | Cmutability (r, v) -> r := v | Cuniv (r, v) -> r := v | Ctypeset (r, v) -> r := v @@ -781,9 +739,6 @@ let set_mutability r v = log_change (Cmutability (r, !r)); r := v -let set_kind rk k = - log_change (Ckind (rk, !rk)); - rk := Some k let set_typeset rs s = log_change (Ctypeset (rs, !rs)); rs := s diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 3f8b9db6f7..375f22b283 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -49,16 +49,11 @@ val newgenvar : ?name:string -> unit -> type_expr val is_Tvar : type_expr -> bool val is_Tunivar : type_expr -> bool val is_Tconstr : type_expr -> bool -val dummy_method : label val default_mty : module_type option -> module_type val repr : type_expr -> type_expr (* Return the canonical representative of a type. *) -val field_kind_repr : field_kind -> field_kind -(* Return the canonical representative of an object field - kind. *) - (**** polymorphic variants ****) val row_repr : row_desc -> row_desc @@ -128,14 +123,10 @@ val copy_type_desc : val copy_row : (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc -val copy_kind : field_kind -> field_kind val save_desc : type_expr -> type_desc -> unit (* Save a type description *) -val dup_kind : field_kind option ref -> unit -(* Save a None field_kind, and make it point to a fresh Fvar *) - val with_copy_session : (unit -> 'a) -> 'a val lowest_level : int @@ -216,7 +207,6 @@ val set_name : unit val set_row_field : row_field option ref -> row_field -> unit val set_univar : type_expr option ref -> type_expr -> unit -val set_kind : field_kind option ref -> field_kind -> unit (* Logged (backtrackable) update of a mutability cell: promotion ([Mutability_value Mutable]) or an equivalence-class merge diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index e261184a00..df07a79e7c 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -263,7 +263,6 @@ let is_datatype decl = type field_info = { f_name: string; - f_kind: Types.field_kind; f_mut: Types.field_mutability ref; (* the field's cell as stored; read its class value with [Btype.mutability_repr] *) @@ -282,27 +281,17 @@ let flatten_fields (ty : Types.type_expr) : fields * _ = let rec flatten (l : fields) ty = let ty = repr ty in match ty.desc with - | Tfield {name; presence; mutability; typ; rest} -> - flatten - ({f_name = name; f_kind = presence; f_mut = mutability; f_typ = typ} - :: l) - rest + | Tfield {name; mutability; typ; rest} -> + flatten ({f_name = name; f_mut = mutability; f_typ = typ} :: l) rest | _ -> (l, ty) in let l, r = flatten [] ty in (List.sort (fun f f' -> compare f.f_name f'.f_name) l, r) let build_fields level = - List.fold_right (fun {f_name; f_kind; f_mut; f_typ} rest -> + List.fold_right (fun {f_name; f_mut; f_typ} rest -> newty2 level - (Tfield - { - name = f_name; - presence = f_kind; - mutability = f_mut; - typ = f_typ; - rest; - })) + (Tfield {name = f_name; mutability = f_mut; typ = f_typ; rest})) let associate_fields (fields1 : fields) (fields2 : fields) : _ * fields * fields = @@ -607,9 +596,6 @@ let rec update_level env level expand ty = | _ -> ()); set_level ty level; iter_type_expr (update_level env level expand) ty - | Tfield {name = lab; typ = ty1} - when lab = dummy_method && (repr ty1).level > level -> - raise (Unify [(ty1, newvar2 level)]) | _ -> set_level ty level; (* XXX what about abbreviations in Tconstr ? *) @@ -850,13 +836,6 @@ let rec copy ?env ?partial ?keep_names ty = more.desc <- Tsubst (newgenty (Ttuple [more'; t])); (* Return a new copy *) Tvariant (copy_row copy true row keep more')) - | Tfield {presence = k; rest = ty2} -> ( - match field_kind_repr k with - | Fabsent -> Tlink (copy ty2) - | Fpresent -> copy_type_desc copy desc - | Fvar r -> - dup_kind r; - copy_type_desc copy desc) | Tobject ty1 when partial <> None -> Tobject (copy ty1) | _ -> copy_type_desc ?keep_names copy desc); t @@ -1822,26 +1801,12 @@ and mcomp_fields type_pairs env ty1 ty2 = let fields2, rest2 = flatten_fields ty2 in let fields1, rest1 = flatten_fields ty1 in let pairs, miss1, miss2 = associate_fields fields1 fields2 in - let has_present = - List.exists (fun f -> field_kind_repr f.f_kind = Fpresent) - in mcomp type_pairs env rest1 rest2; if - (has_present miss1 && (object_row ty2).desc = Tnil) - || (has_present miss2 && (object_row ty1).desc = Tnil) + (miss1 <> [] && (object_row ty2).desc = Tnil) + || (miss2 <> [] && (object_row ty1).desc = Tnil) then raise (Unify []); - List.iter - (fun (f1, f2) -> - mcomp_kind f1.f_kind f2.f_kind; - mcomp type_pairs env f1.f_typ f2.f_typ) - pairs - -and mcomp_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match (k1, k2) with - | Fpresent, Fabsent | Fabsent, Fpresent -> raise (Unify []) - | _ -> () + List.iter (fun (f1, f2) -> mcomp type_pairs env f1.f_typ f2.f_typ) pairs and mcomp_row type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in @@ -2268,14 +2233,6 @@ and unify3 env t1 t1' t2 t2' = reify env t1'; reify env t2'; if !generate_equations then mcomp !env t1' t2') - | Tfield {name = f; presence = kind; rest = rem}, Tnil - | Tnil, Tfield {name = f; presence = kind; rest = rem} -> ( - match field_kind_repr kind with - | Fvar r when f <> dummy_method -> - set_kind r Fabsent; - if d2 = Tnil then unify env rem t2' - else unify env (newty2 rem.level Tnil) rem - | _ -> raise (Unify [])) | Tnil, Tnil -> () | Tpoly (t1, []), Tpoly (t2, []) -> unify env t1 t2 | Tpoly (t1, tl1), Tpoly (t2, tl2) -> @@ -2350,7 +2307,6 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = unify env rest1 (build_fields l2 miss2 va); List.iter (fun (f1, f2) -> - unify_kind f1.f_kind f2.f_kind; unify_mutability ~open1 ~open2 f1 f2; try if !trace_gadt_instances then update_level !env va.level f1.f_typ; @@ -2362,7 +2318,6 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = (Tfield { name = f1.f_name; - presence = f1.f_kind; mutability = f1.f_mut; typ = f1.f_typ; rest = newty Tnil; @@ -2371,7 +2326,6 @@ and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = (Tfield { name = f2.f_name; - presence = f2.f_kind; mutability = f2.f_mut; typ = f2.f_typ; rest = newty Tnil; @@ -2403,17 +2357,6 @@ and unify_mutability ~open1 ~open2 f1 f2 = every present and future member of either class share one state. *) set_mutability r2 (Mutability_link r1)) -and unify_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () - else - match (k1, k2) with - | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 - | Fpresent, Fvar r -> set_kind r k1 - | Fpresent, Fpresent -> () - | _ -> assert false - and unify_row env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = row_more row1 and rm2 = row_more row2 in @@ -2679,7 +2622,7 @@ let filter_arrow_n ~env t (labels : arg_label list) = | _ -> raise (Unify []) (* Used by [filter_method]. *) -let rec filter_method_field env name priv ty = +let rec filter_method_field env name ty = let ty = expand_head_trace env ty in match ty.desc with | Tvar _ -> @@ -2690,10 +2633,6 @@ let rec filter_method_field env name priv ty = (Tfield { name; - presence = - (match priv with - | Private -> Fvar (ref None) - | Public -> Fpresent); mutability = ref (Mutability_value Asttypes.Immutable); typ = ty1; rest = ty2; @@ -2701,12 +2640,8 @@ let rec filter_method_field env name priv ty = in link_type ty ty'; ty1 - | Tfield {name = n; presence = kind; typ = ty1; rest = ty2} -> - let kind = field_kind_repr kind in - if n = name && kind <> Fabsent then ( - if priv = Public then unify_kind kind Fpresent; - ty1) - else filter_method_field env name priv ty2 + | Tfield {name = n; typ = ty1; rest = ty2} -> + if n = name then ty1 else filter_method_field env name ty2 | _ -> raise (Unify []) type object_field_write_error = Owrite_missing | Owrite_not_mutable @@ -2730,7 +2665,6 @@ let filter_object_field_for_write env name ty : (Tfield { name; - presence = Fpresent; mutability = ref (Mutability_value Asttypes.Mutable); typ = ty1; rest = ty2; @@ -2738,10 +2672,8 @@ let filter_object_field_for_write env name ty : in link_type ty ty'; Ok ty1 - | Tfield ({name = n; presence = kind; mutability; typ} as f) -> - let kind = field_kind_repr kind in - if n = name && kind <> Fabsent then ( - unify_kind kind Fpresent; + | Tfield ({name = n; mutability; typ} as f) -> + if n = name then match mutability_repr mutability with | Asttypes.Mutable -> Ok typ | Immutable -> @@ -2750,7 +2682,7 @@ let filter_object_field_for_write env name ty : (mutability_ref_repr mutability) (Mutability_value Asttypes.Mutable); Ok typ) - else Error Owrite_not_mutable) + else Error Owrite_not_mutable else write_field ~opened f.rest | _ -> Error Owrite_missing in @@ -2765,8 +2697,8 @@ let filter_object_field_for_write env name ty : | Tobject f -> write_field ~opened:(opened_object ty) f | _ -> Error Owrite_missing -(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) -let filter_method env name priv ty = +(* Unify [ty] and [{.. name: 'a}]. Return ['a]. *) +let filter_method env name ty = let ty = expand_head_trace env ty in match ty.desc with | Tvar _ -> @@ -2774,8 +2706,8 @@ let filter_method env name priv ty = let ty' = newobj ty1 in update_level env ty.level ty'; link_type ty ty'; - filter_method_field env name priv ty1 - | Tobject f -> filter_method_field env name priv f + filter_method_field env name ty1 + | Tobject f -> filter_method_field env name f | _ -> raise (Unify []) let moregen_occur env level ty = @@ -2882,7 +2814,6 @@ and moregen_fields inst_nongen type_pairs env ty1 ty2 = (build_fields (repr ty2).level miss2 rest2); List.iter (fun (f1, f2) -> - moregen_kind f1.f_kind f2.f_kind; if mutability_repr f1.f_mut <> mutability_repr f2.f_mut then raise (Unify []); try moregen inst_nongen type_pairs env f1.f_typ f2.f_typ @@ -2893,7 +2824,6 @@ and moregen_fields inst_nongen type_pairs env ty1 ty2 = (Tfield { name = f1.f_name; - presence = f1.f_kind; mutability = f1.f_mut; typ = f1.f_typ; rest = rest2; @@ -2902,7 +2832,6 @@ and moregen_fields inst_nongen type_pairs env ty1 ty2 = (Tfield { name = f2.f_name; - presence = f2.f_kind; mutability = f2.f_mut; typ = f2.f_typ; rest = rest2; @@ -2910,16 +2839,6 @@ and moregen_fields inst_nongen type_pairs env ty1 ty2 = :: trace))) pairs -and moregen_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () - else - match (k1, k2) with - | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 - | Fpresent, Fpresent -> () - | _ -> raise (Unify []) - and moregen_row inst_nongen type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = repr row1.row_more and rm2 = repr row2.row_more in @@ -3188,7 +3107,6 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = if miss1 <> [] || miss2 <> [] then raise (Unify []); List.iter (fun (f1, f2) -> - eqtype_kind f1.f_kind f2.f_kind; if mutability_repr f1.f_mut <> mutability_repr f2.f_mut then raise (Unify []); try eqtype rename type_pairs subst env f1.f_typ f2.f_typ @@ -3199,7 +3117,6 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = (Tfield { name = f1.f_name; - presence = f1.f_kind; mutability = f1.f_mut; typ = f1.f_typ; rest = rest2; @@ -3208,7 +3125,6 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = (Tfield { name = f2.f_name; - presence = f2.f_kind; mutability = f2.f_mut; typ = f2.f_typ; rest = rest2; @@ -3216,13 +3132,6 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = :: trace))) pairs -and eqtype_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match (k1, k2) with - | Fvar _, Fvar _ | Fpresent, Fpresent -> () - | _ -> raise (Unify []) - and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) match expand_head_rigid env (row_more row2) with @@ -3463,7 +3372,6 @@ let rec build_subtype env visited loops posi level t = (Tfield { f with - presence = Fpresent; (* The enlarged type is an approximation, not a view of the declared type: it gets its own unlinked cell, so trial unification can never promote the declared target or the @@ -3964,7 +3872,6 @@ and subtype_fields env trace ty1 ty2 cstrs = (Tfield { name = f1.f_name; - presence = f1.f_kind; mutability = f1.f_mut; typ = f1.f_typ; rest = rest1; @@ -3975,7 +3882,6 @@ and subtype_fields env trace ty1 ty2 cstrs = (Tfield { name = f2.f_name; - presence = f2.f_kind; mutability = f2.f_mut; typ = f2.f_typ; rest = newvar (); @@ -4104,8 +4010,8 @@ let rec closed_schema_rec env ty = visited := old; closed_schema_rec env (try_expand_head try_expand_safe env ty) with Cannot_expand -> raise Non_closed0)) - | Tfield {presence = kind; typ = t1; rest = t2} -> - if field_kind_repr kind = Fpresent then closed_schema_rec env t1; + | Tfield {typ = t1; rest = t2} -> + closed_schema_rec env t1; closed_schema_rec env t2 | Tvariant row -> let row = row_repr row in diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index d6dcba52f8..f5ab08bfd8 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -104,7 +104,6 @@ val object_fields : type_expr -> type_expr type field_info = { f_name: string; - f_kind: field_kind; f_mut: field_mutability ref; (* the field's cell as stored; read the class value with [Btype.mutability_repr] *) @@ -219,7 +218,7 @@ val filter_arrow_n : (* A special case of unification: unify with an n-ary arrow taking parameters with the given labels; return parameter and result types. *) -val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr +val filter_method : Env.t -> string -> type_expr -> type_expr type object_field_write_error = Owrite_missing | Owrite_not_mutable diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 7c8a47baaa..74eb7883e1 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -110,27 +110,6 @@ let raw_list pr ppf = function fprintf ppf "@[<1>[%a%t]@]" pr a (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) -let kind_vars = ref [] -let kind_count = ref 0 - -let rec safe_kind_repr v = function - | Fvar {contents = Some k} -> - if List.memq k v then "Fvar loop" else safe_kind_repr (k :: v) k - | Fvar r -> - let vid = - try List.assq r !kind_vars - with Not_found -> - let c = - incr kind_count; - !kind_count - in - kind_vars := (r, c) :: !kind_vars; - c - in - Printf.sprintf "Fvar {None}@%d" vid - | Fpresent -> "Fpresent" - | Fabsent -> "Fabsent" - let rec safe_repr v = function | {desc = Tlink t} when not (List.memq t v) -> safe_repr (t :: v) t | t -> t @@ -173,9 +152,8 @@ and raw_type_desc ppf = function fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl (raw_list path) (list_of_memo !abbrev) | Tobject t -> fprintf ppf "@[Tobject@,%a@]" raw_type t - | Tfield {name = f; presence = k; mutability; typ = t1; rest = t2} -> - fprintf ppf "@[Tfield(@,%s,@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (safe_kind_repr [] k) + | Tfield {name = f; mutability; typ = t1; rest = t2} -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f (match Btype.mutability_repr mutability with | Mutable -> "mutable" | Immutable -> "immutable") @@ -213,11 +191,8 @@ and raw_field ppf = function let raw_type_expr ppf t = visited := []; - kind_vars := []; - kind_count := 0; raw_type ppf t; - visited := []; - kind_vars := [] + visited := [] let () = Btype.print_raw := raw_type_expr @@ -528,16 +503,10 @@ let rec mark_loops_rec visited ty = else ( if opened_object ty then visited_objects := px :: !visited_objects; let fields, _ = flatten_fields fi in - List.iter - (fun {Ctype.f_kind; f_typ} -> - if field_kind_repr f_kind = Fpresent then - mark_loops_rec visited f_typ) - fields) - | Tfield {presence = kind; typ = ty1; rest = ty2} - when field_kind_repr kind = Fpresent -> + List.iter (fun {Ctype.f_typ} -> mark_loops_rec visited f_typ) fields) + | Tfield {typ = ty1; rest = ty2} -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield {rest = ty2} -> mark_loops_rec visited ty2 | Tnil -> () | Tsubst ty -> mark_loops_rec visited ty | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" @@ -741,13 +710,10 @@ and tree_of_typlist ?printing_context sch tyl = and tree_of_typobject ?printing_context sch fi = let fields, rest = flatten_fields fi in let present_fields = - List.fold_right - (fun {f_name; f_kind; f_mut; f_typ} l -> - match field_kind_repr f_kind with - | Fpresent -> - (f_name, Btype.mutability_repr f_mut = Asttypes.Mutable, f_typ) :: l - | _ -> l) - fields [] + List.map + (fun {f_name; f_mut; f_typ} -> + (f_name, Btype.mutability_repr f_mut = Asttypes.Mutable, f_typ)) + fields in let sorted_fields = List.sort (fun (n, _, _) (n', _, _) -> String.compare n n') present_fields @@ -1335,10 +1301,6 @@ let explanation unif t3 t4 ppf = else fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" type_expr t' "it would escape the scope of its equation" - | Tfield {name = lab}, _ when lab = dummy_method -> - fprintf ppf "@,Self type cannot be unified with a closed object type" - | _, Tfield {name = lab} when lab = dummy_method -> - fprintf ppf "@,Self type cannot be unified with a closed object type" | ( Tfield {name = l; typ = f1; rest = {desc = Tnil}}, Tfield {name = l'; typ = f2; rest = {desc = Tnil}} ) when l = l' -> diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 0c092bb52a..3d734f37ec 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -140,12 +140,6 @@ let rec typexp_rec s ty = ty') else ty | Tsubst ty -> ty - | Tfield {name = m; presence = k} - when (not s.for_saving) && m = dummy_method - && field_kind_repr k <> Fabsent - && (repr ty).level < generic_level -> - (* do not copy the type of self when it is not generalized *) - ty (* cannot do it, since it would omit substitution | Tvariant row when not (static_row row) -> ty @@ -225,9 +219,6 @@ let rec typexp_rec s ty = else Some (type_path s p, tl)); } | None -> Tvariant row)) - | Tfield {presence = kind; rest = t2} - when field_kind_repr kind = Fabsent -> - Tlink (typexp_rec s t2) | _ -> copy_type_desc (typexp_rec s) desc); ty' diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index c96dff42ce..10ac4a6f76 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2350,9 +2350,7 @@ let object_valid_fields env ty = match (expand_head env ty).desc with | Tobject fields -> let fields, _ = Ctype.flatten_fields fields in - let collect_fields li (f : Ctype.field_info) = - if f.f_kind = Fpresent then f.f_name :: li else li - in + let collect_fields li (f : Ctype.field_info) = f.f_name :: li in Some (List.fold_left collect_fields [] fields) | _ -> None @@ -3352,7 +3350,6 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp (Tfield { name = s.txt; - presence = Fpresent; mutability = ref (Mutability_value Asttypes.Immutable); typ = newty (Tpoly (field.exp_type, [])); rest; @@ -3371,7 +3368,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Pexp_object_get (e, ({txt = met} as met_loc)) -> ( let obj = type_exp ~context:None env e in try - let typ = filter_method env met Public obj.exp_type in + let typ = filter_method env met obj.exp_type in let typ = object_field_use_type env typ in rue { diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 2125b82a04..da22631825 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -31,7 +31,6 @@ and type_desc = | Tobject of type_expr | Tfield of { name: string; - presence: field_kind; mutability: field_mutability ref; typ: type_expr; rest: type_expr; @@ -65,8 +64,6 @@ and abbrev_memo = | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref -and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent - and field_mutability = | Mutability_value of Asttypes.mutable_flag | Mutability_link of field_mutability ref diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 44d46651c4..0105d01f47 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -89,12 +89,11 @@ and type_desc = constructors, terminated by a row variable when the row is open. *) | Tfield of { name: string; - presence: field_kind; mutability: field_mutability ref; typ: type_expr; rest: type_expr; } - (** [Tfield {name = "foo"; presence = Fpresent; mutability; typ; rest}] + (** [Tfield {name = "foo"; mutability; typ; rest}] ==> [{.. "foo": typ, rest}]; [mutability] records whether the field admits assignment ([@set]). *) | Tnil (** [Tnil] ==> [<...; >] *) @@ -183,8 +182,6 @@ and abbrev_memo = | Mlink of abbrev_memo ref (** Abbreviations can be found after this indirection *) -and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent - (** Mutability state of an object field, shared through an equivalence class of cells. [Mutability_link] is an internal graph edge (union by unification, duplication memo during copying) — never a third semantic diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index ce129a8e71..c5d9999f34 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -641,7 +641,6 @@ and transl_fields env policy o fields = (Tfield { name = s; - presence = Fpresent; mutability = ref (Mutability_value mut); typ = ty'; rest = ty; diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index c6a906eeb1..8eb91ae65b 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -207,7 +207,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Or_pattern_type_clash` | ✓ | `or_pattern_type_clash.res` | | | `Multiply_bound_variable` | ✓ | `multiply_bound_variable.res` | | | `Orpat_vars` | ✓ | `orpat_vars_unbalanced.res` | | -| `Expr_type_clash` | ✓ | many `*.res` | Most-fired expression error. Trace-shape sub-cases covered: `if_return_type_mismatch.res` (IfReturn), `maybe_unwrap_option.res` (MaybeUnwrapOption), `string_concat_non_string.res` (StringConcat), `labeled_fn_argument_type_clash.res` (FunctionArgument with explicit label), `math_operator_*.res` (MathOperator family), `ternary_branch_mismatch.res`, `switch_different_types.res`, `try_catch_same_type.res`, `comparison_operator.res`, `array_item_type_mismatch.res`, `array_literal_passed_to_tuple.res`, `if_condition_mismatch.res`, `while_condition.res`, `for_loop_condition.res`, `assert_condition.res`, `function_call_mismatch.res`, `awaiting_non_promise.res`, multiple `jsx_*` fixtures. | +| `Expr_type_clash` | ✓ | many `*.res` | Most-fired expression error. Trace-shape sub-cases covered: `if_return_type_mismatch.res` (IfReturn), `maybe_unwrap_option.res` (MaybeUnwrapOption), `string_concat_non_string.res` (StringConcat), `labeled_fn_argument_type_clash.res` (FunctionArgument with explicit label), `math_operator_*.res` (MathOperator family), `ternary_branch_mismatch.res`, `switch_different_types.res`, `try_catch_same_type.res`, `comparison_operator.res`, `array_item_type_mismatch.res`, `array_literal_passed_to_tuple.res`, `if_condition_mismatch.res`, `while_condition.res`, `for_loop_condition.res`, `assert_condition.res`, `function_call_mismatch.res`, `awaiting_non_promise.res`, multiple `jsx_*` fixtures, `object_literal_for_poly_field.res` (object literal against a polymorphic field annotation). | | `Apply_non_function` | ✓ | `apply_non_function.res` | | | `Apply_wrong_label` | ✓ | `apply_wrong_label.res` | | | `Label_multiply_defined` | ✓ | `label_multiply_defined_literal.res` | | diff --git a/tests/build_tests/super_errors/expected/object_literal_for_poly_field.res.expected b/tests/build_tests/super_errors/expected/object_literal_for_poly_field.res.expected new file mode 100644 index 0000000000..9a7cd8518c --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_literal_for_poly_field.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/object_literal_for_poly_field.res:5:12-24 + + 3 │ Tpoly(['a]) unification failure. */ + 4 │ type t = {"f": 'a. 'a => 'a} + 5 │ let x: t = {"f": x => x} + 6 │ + + This has type: {"f": 'a => 'a} + But it's expected to have type: t + The universal variable 'a0 would escape its scope \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/object_literal_for_poly_field.res b/tests/build_tests/super_errors/fixtures/object_literal_for_poly_field.res new file mode 100644 index 0000000000..f820288f80 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_literal_for_poly_field.res @@ -0,0 +1,5 @@ +/* An object literal cannot satisfy a polymorphic field annotation: the + literal's field is monomorphic. Pins the current Tpoly([]) vs + Tpoly(['a]) unification failure. */ +type t = {"f": 'a. 'a => 'a} +let x: t = {"f": x => x} diff --git a/tests/ounit_tests/ounit_object_mutability_tests.ml b/tests/ounit_tests/ounit_object_mutability_tests.ml index 0766ea10d3..0c2cc17b27 100644 --- a/tests/ounit_tests/ounit_object_mutability_tests.ml +++ b/tests/ounit_tests/ounit_object_mutability_tests.ml @@ -22,14 +22,7 @@ let obj_with_cell ?(closed = false) cell = let rest = if closed then Ctype.newty Types.Tnil else Ctype.newvar () in Ctype.newobj (Ctype.newty - (Types.Tfield - { - name = "x"; - presence = Types.Fpresent; - mutability = cell; - typ = int_typ (); - rest; - })) + (Types.Tfield {name = "x"; mutability = cell; typ = int_typ (); rest})) let field_of ty = match Ctype.flatten_fields (Ctype.object_fields ty) with diff --git a/tests/tests/src/object_poly_field.mjs b/tests/tests/src/object_poly_field.mjs new file mode 100644 index 0000000000..8fbc9fb5bf --- /dev/null +++ b/tests/tests/src/object_poly_field.mjs @@ -0,0 +1,33 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function use_poly(o) { + return [ + o.id(1), + o.id("x") + ]; +} + +function forget_extra(o) { + return o; +} + +function use_open(o) { + return [ + o.id(1), + o.id("x") + ]; +} + +let value = ({id: x => x}); + +let pair = use_poly(value); + +export { + use_poly, + forget_extra, + use_open, + value, + pair, +} +/* value Not a pure module */ diff --git a/tests/tests/src/object_poly_field.res b/tests/tests/src/object_poly_field.res new file mode 100644 index 0000000000..579752128b --- /dev/null +++ b/tests/tests/src/object_poly_field.res @@ -0,0 +1,21 @@ +/* Pins polymorphic object fields ({"f": 'a. ...}): the Tpoly binder on an + object field is a live surface feature (Stage E survey). Every case in + this file must keep compiling. The rejection of an object literal for a + polymorphic field is pinned in + tests/build_tests/super_errors/fixtures/object_literal_for_poly_field.res. */ + +type poly = {"id": 'a. 'a => 'a} + +/* An annotated polymorphic field is usable at several types. */ +let use_poly = (o: poly) => (o["id"](1), o["id"]("x")) + +/* Polymorphic fields participate in width subtyping like any field. */ +let forget_extra = (o: {"id": 'a. 'a => 'a, "extra": int}): poly => (o :> poly) + +/* Access through an open row preserves the field's polymorphism. */ +let use_open = (o: {.."id": 'a. 'a => 'a}) => (o["id"](1), o["id"]("x")) + +/* A polymorphic field of an object value produced by raw JS. */ +let value: poly = %raw(`{id: x => x}`) + +let pair = use_poly(value) diff --git a/tests/tests/src/object_poly_field.resi b/tests/tests/src/object_poly_field.resi new file mode 100644 index 0000000000..79d8b0ffd6 --- /dev/null +++ b/tests/tests/src/object_poly_field.resi @@ -0,0 +1,10 @@ +/* Signature inclusion over object types with polymorphic fields: pins + moregen/eqtype on Tpoly-typed fields (Stage E). */ + +type poly = {"id": 'a. 'a => 'a} + +let use_poly: poly => (int, string) +let forget_extra: {"id": 'a. 'a => 'a, "extra": int} => poly +let use_open: {.."id": 'a. 'a => 'a} => (int, string) +let value: poly +let pair: (int, string) From 520f91a3f65d8f82c92f3fd134c042d112277314 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 28 Aug 2026 15:32:40 +0200 Subject: [PATCH 08/13] Give saved graphs independent mutability classes Saving previously duplicated a field's mutability class only when the row terminator was generic, sharing the resolved source cell otherwise. That left one lifetime exception to the copy invariant: a structure-generalized source (non-generic terminator, share policy) and its saved copy (generic terminator after for_saving relevels, duplicate policy) could own one class with incompatible row-copy classifications - copying both in a single session would then pick a policy depending on which owner was reached first. copy_type_desc gains a fresh_mutability flag and Subst.typexp_rec passes it for for_saving, so a saved graph now owns fresh value cells unconditionally: it shares no mutability class with its source, contains no link chains, and duplication through the session memo still preserves equivalence-class sharing within the saved graph. Ordinary copying alone decides sharing from row-terminator genericity. In passing, the Tlink arm of copy_type_desc now forwards keep_names (and the new flag) instead of silently dropping them on recursion. New pins: for_saving_copy_order_is_irrelevant builds the previously hazardous fixture (source and saved copy with different terminator classifications) and copies both in one session in both orders; for_saving_fresh_copy_preserves_internal_aliasing checks freshness keeps intra-graph sharing; the closed-row saving test now also asserts the saved cell is not the source's. The q1_ test-name prefixes are dropped along with the retracted universal terminator-sharing claim they referred to. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- compiler/ml/btype.ml | 28 ++--- compiler/ml/btype.mli | 6 +- compiler/ml/subst.ml | 3 +- .../ounit_object_mutability_tests.ml | 101 +++++++++++++----- 4 files changed, 98 insertions(+), 40 deletions(-) diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index b420fc46b2..435fdb95ac 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -454,10 +454,10 @@ let dup_mutability r = r := Mutability_link r'; r' -(* Copy policy for an object row, memoized per node so copying a row is - linear in its length: duplicate the mutability cells iff the row ends in - a generic variable (a scheme instantiation); share them otherwise (a - structure-generalized copy, whose occurrences must see promotions). *) +(* Copy policy for an object row, memoized per node so its terminator is + classified once per session: duplicate the mutability cells iff the row + ends in a generic variable (a scheme instantiation); share them otherwise + (a structure-generalized copy, whose occurrences must see promotions). *) let row_terminator_generic rest = let session = current_type_copy_session () in let copy_policy_memo = @@ -489,7 +489,8 @@ let row_terminator_generic rest = in go rest -let rec copy_type_desc ?(keep_names = false) f = function +let rec copy_type_desc ?(keep_names = false) ?(fresh_mutability = false) f = + function | Tvar _ as ty -> if keep_names then ty else Tvar None | Tarrow (params, ret) -> Tarrow (List.map (fun arg -> {arg with typ = f arg.typ}) params, f ret) @@ -498,19 +499,20 @@ let rec copy_type_desc ?(keep_names = false) f = function | Tobject ty -> Tobject (f ty) | Tvariant _ -> assert false (* too ambiguous *) | Tfield f_ -> - (* The mutability cell follows the row variable's sharing law: - instantiating a generalized row (generic terminator) duplicates each - cell once per session via [dup_mutability], so aliases within the - instance stay correlated while the scheme and sibling instances are - untouched; other copies hold the shared representative, so - promotions reach every occurrence. *) + (* Unless the caller requests an independent graph, the mutability cell + follows the row variable's sharing law: instantiating a generalized row + (generic terminator) duplicates each cell once per session via + [dup_mutability], so aliases within the instance stay correlated while + the scheme and sibling instances are untouched; other copies hold the + shared representative, so promotions reach every occurrence. *) let mutability = - if row_terminator_generic f_.rest then dup_mutability f_.mutability + if fresh_mutability || row_terminator_generic f_.rest then + dup_mutability f_.mutability else mutability_ref_repr f_.mutability in Tfield {f_ with mutability; typ = f f_.typ; rest = f f_.rest} | Tnil -> Tnil - | Tlink ty -> copy_type_desc f ty.desc + | Tlink ty -> copy_type_desc ~keep_names ~fresh_mutability f ty.desc | Tsubst _ -> assert false | Tunivar _ as ty -> ty (* always keep the name *) | Tpoly (ty, tyl) -> diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 375f22b283..d8f47a5142 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -118,7 +118,11 @@ val unmark_iterators : type_iterators (* Unmark any structure containing types. See [unmark_type] below. *) val copy_type_desc : - ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc + ?keep_names:bool -> + ?fresh_mutability:bool -> + (type_expr -> type_expr) -> + type_desc -> + type_desc (* Copy on types *) val copy_row : diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 3d734f37ec..b98a5a4a24 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -219,7 +219,8 @@ let rec typexp_rec s ty = else Some (type_path s p, tl)); } | None -> Tvariant row)) - | _ -> copy_type_desc (typexp_rec s) desc); + | _ -> + copy_type_desc ~fresh_mutability:s.for_saving (typexp_rec s) desc); ty' (* diff --git a/tests/ounit_tests/ounit_object_mutability_tests.ml b/tests/ounit_tests/ounit_object_mutability_tests.ml index 0c2cc17b27..335da3ca34 100644 --- a/tests/ounit_tests/ounit_object_mutability_tests.ml +++ b/tests/ounit_tests/ounit_object_mutability_tests.ml @@ -1,5 +1,5 @@ (* Representation-level tests for object-field mutability state: the - linkable [field_mutability] cells in [Tfield] (doc §7). These properties + linkable [field_mutability] cells in [Tfield] (doc §6.7). These properties are not observable from generated JavaScript, so they are tested here directly against [Ctype]/[Btype]. @@ -149,9 +149,7 @@ let test_structure_generalized_occurrences_share _ = assert_bool "promotion is visible through the annotation itself" (flag_of annotated = Asttypes.Mutable) -(* ---- §7.4 Q1: every path that shares a mutability class between two - owners also shares the row terminator node, so terminator genericity is - a property of the sharing class and the copy policy is well defined. *) +(* Copy-policy coverage for ordinary typing and substitution paths. *) let terminator_of ty = let _, rest = Ctype.flatten_fields (Ctype.object_fields ty) in @@ -173,14 +171,14 @@ let abstract_type_decl type_manifest : Types.type_declaration = type_inlined_types = []; } -let test_q1_unified_owners_share_terminator _ = +let test_unified_owners_share_terminator _ = let a = obj_with_cell (immutable_cell ()) in let b = obj_with_cell ~closed:true (immutable_cell ()) in Ctype.unify Env.empty a b; assert_bool "unification makes both rows end at the same terminator node" (terminator_of a == terminator_of b) -let test_q1_shared_copy_shares_terminator _ = +let test_shared_copy_shares_terminator _ = let annotated = obj_with_cell (immutable_cell ()) in Ctype.generalize_structure annotated; let occurrence = Ctype.instance Env.empty annotated in @@ -188,7 +186,7 @@ let test_q1_shared_copy_shares_terminator _ = assert_bool "terminator shared" (terminator_of occurrence == terminator_of annotated) -let test_q1_generalized_instance_fresh_cell_fresh_terminator _ = +let test_generalized_instance_fresh_cell_fresh_terminator _ = Ctype.begin_def (); let scheme = obj_with_cell (immutable_cell ()) in Ctype.end_def (); @@ -197,7 +195,7 @@ let test_q1_generalized_instance_fresh_cell_fresh_terminator _ = assert_bool "class fresh" (cell_of inst != cell_of scheme); assert_bool "terminator fresh" (terminator_of inst != terminator_of scheme) -let test_q1_subst_generic_copy_gets_fresh_cell _ = +let test_subst_generic_copy_gets_fresh_cell _ = Ctype.begin_def (); let scheme = obj_with_cell (immutable_cell ()) in Ctype.end_def (); @@ -283,12 +281,10 @@ let test_nondep_failure_ends_copy_session _ = | Types.Mutability_value Asttypes.Immutable -> true | Types.Mutability_value Asttypes.Mutable | Types.Mutability_link _ -> false) -let test_saving_closed_row_resolves_links _ = - (* Closed rows have no generic terminator, so saving shares the source's - cell rather than duplicating it (safe: marshalling deep-copies). The - shared cell must be the resolved representative — saved graphs never - contain [Mutability_link], even when the source field's own ref is a - link left by an earlier class merge. *) +let test_saving_closed_row_gets_fresh_resolved_cell _ = + (* A saved graph owns fresh cells even for closed rows. The copied cell must + contain the resolved value: saved graphs never contain [Mutability_link], + even when the source field's own ref is a merged-class link. *) let rep = immutable_cell () in let a = obj_with_cell ~closed:true (ref (Types.Mutability_link rep)) in assert_bool "the source field holds a link (a merged class member)" @@ -301,7 +297,9 @@ let test_saving_closed_row_resolves_links _ = | Types.Mutability_value _ -> true | Types.Mutability_link _ -> false); assert_bool "the saved flag is the class value" - (flag_of saved = Asttypes.Immutable) + (flag_of saved = Asttypes.Immutable); + assert_bool "the saved graph does not retain the source cell" + (cell_of saved != cell_of a) let test_saving_marshal_round_trip _ = (* The real persistence claim: after [for_saving] the graph marshals, and @@ -350,6 +348,56 @@ let test_saving_preserves_class_sharing _ = | Types.Mutability_value _ -> true | Types.Mutability_link _ -> false) +let test_for_saving_copy_order_is_irrelevant _ = + (* [generalize_structure] makes the field spine generic while leaving its + open-row terminator non-generic. [for_saving] makes the copied terminator + generic. If the two graphs still share one mutability cell, copying them + in one session can then choose different policies for that cell. *) + Ctype.begin_def (); + let source = obj_with_cell (immutable_cell ()) in + Ctype.end_def (); + Ctype.generalize_structure source; + let saved = Subst.type_expr (Subst.for_saving Subst.identity) source in + assert_bool "the fixture has different row-copy classifications" + ((terminator_of source).level <> Btype.generic_level + && (terminator_of saved).level = Btype.generic_level); + assert_bool "for_saving gives the copied graph an independent class" + (cell_of source != cell_of saved); + let copy_pair first second = + match Ctype.instance_list Env.empty [first; second] with + | [first'; second'] -> (first', second') + | _ -> OUnit.assert_failure "expected two copied object types" + in + let source_first, saved_second = copy_pair source saved in + let saved_first, source_second = copy_pair saved source in + let source_first_shares = cell_of source_first == cell_of saved_second in + let saved_first_shares = cell_of saved_first == cell_of source_second in + assert_bool "source-first copies are separate" (not source_first_shares); + assert_bool "saved-first copies are separate" (not saved_first_shares); + assert_bool + "copying owners of one class must not depend on their order in the session" + (source_first_shares = saved_first_shares) + +let test_for_saving_fresh_copy_preserves_internal_aliasing _ = + Ctype.begin_def (); + let cell = immutable_cell () in + let source = + Ctype.newty (Types.Ttuple [obj_with_cell cell; obj_with_cell cell]) + in + Ctype.end_def (); + Ctype.generalize_structure source; + let saved = Subst.type_expr (Subst.for_saving Subst.identity) source in + let source_a, source_b, saved_a, saved_b = + match ((Btype.repr source).desc, (Btype.repr saved).desc) with + | Types.Ttuple [source_a; source_b], Types.Ttuple [saved_a; saved_b] -> + (source_a, source_b, saved_a, saved_b) + | _ -> OUnit.assert_failure "expected source and saved object pairs" + in + assert_bool "the source aliases share one class" + (cell_of source_a == cell_of source_b); + assert_bool "the saved aliases share one fresh class" + (cell_of saved_a == cell_of saved_b && cell_of saved_a != cell_of source_a) + let suites = __FILE__ >::: [ @@ -365,23 +413,26 @@ let suites = >:: test_generalized_instance_preserves_internal_aliasing; "structure_generalized_occurrences_share" >:: test_structure_generalized_occurrences_share; - "q1_unified_owners_share_terminator" - >:: test_q1_unified_owners_share_terminator; - "q1_shared_copy_shares_terminator" - >:: test_q1_shared_copy_shares_terminator; - "q1_generalized_instance_fresh_cell_fresh_terminator" - >:: test_q1_generalized_instance_fresh_cell_fresh_terminator; - "q1_subst_generic_copy_gets_fresh_cell" - >:: test_q1_subst_generic_copy_gets_fresh_cell; + "unified_owners_share_terminator" + >:: test_unified_owners_share_terminator; + "shared_copy_shares_terminator" >:: test_shared_copy_shares_terminator; + "generalized_instance_fresh_cell_fresh_terminator" + >:: test_generalized_instance_fresh_cell_fresh_terminator; + "subst_generic_copy_gets_fresh_cell" + >:: test_subst_generic_copy_gets_fresh_cell; "nondep_type_ends_its_copy_session" >:: test_nondep_type_ends_its_copy_session; "nondep_nested_copy_preserves_class_sharing" >:: test_nondep_nested_copy_preserves_class_sharing; "nondep_failure_ends_copy_session" >:: test_nondep_failure_ends_copy_session; - "saving_closed_row_resolves_links" - >:: test_saving_closed_row_resolves_links; + "saving_closed_row_gets_fresh_resolved_cell" + >:: test_saving_closed_row_gets_fresh_resolved_cell; "saving_marshal_round_trip" >:: test_saving_marshal_round_trip; "saving_preserves_class_sharing" >:: test_saving_preserves_class_sharing; + "for_saving_copy_order_is_irrelevant" + >:: test_for_saving_copy_order_is_irrelevant; + "for_saving_fresh_copy_preserves_internal_aliasing" + >:: test_for_saving_fresh_copy_preserves_internal_aliasing; ] From b4386bc644b94b1db17a1bf9120ac7eb51afaf44 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 29 Aug 2026 09:16:21 +0200 Subject: [PATCH 09/13] Reformat for OCamlFormat 0.29 Formatting-only: the rebase onto master (which upgraded OCamlFormat from 0.27 to 0.29 in #8591) left the files this branch touches formatted with the old version. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- analysis/src/semantic_tokens.ml | 10 +- .../gentype/translate_type_expr_from_types.ml | 148 +++++++++--------- 2 files changed, 76 insertions(+), 82 deletions(-) diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 38d06ec143..3a8f925cd1 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -361,11 +361,11 @@ let command ~debug ~emitter ~source ~kind_file = | Pexp_object_literal fields -> fields |> List.iter (fun ((s : string Asttypes.loc), _) -> - if not (Utils.is_first_char_uppercase s.txt) then - emitter - |> emit_record_label - ~label:{Asttypes.txt = Longident.Lident s.txt; loc = s.loc} - ~debug); + if not (Utils.is_first_char_uppercase s.txt) then + emitter + |> emit_record_label + ~label:{Asttypes.txt = Longident.Lident s.txt; loc = s.loc} + ~debug); Ast_iterator.default_iterator.expr iterator e | Pexp_record (cases, _) -> Ext_list.filter_map cases (fun {lid} -> diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index 38bc9b1218..fb91f0e7fd 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/compiler/gentype/translate_type_expr_from_types.ml @@ -30,18 +30,18 @@ let translate_obj_type closed_flag fields_translations = let fields = fields_translations |> List.map (fun (name, mutable_, {type_ = t}) -> - let optional, type_ = - match t with - | Option t -> (Optional, t) - | _ -> (Mandatory, t) - in - { - mutable_; - name_js = name; - optional; - type_; - doc_string = Doc_string.empty; - }) + let optional, type_ = + match t with + | Option t -> (Optional, t) + | _ -> (Mandatory, t) + in + { + mutable_; + name_js = name; + optional; + type_; + doc_string = Doc_string.empty; + }) in let type_ = Object (closed_flag, fields) in {dependencies; type_} @@ -551,11 +551,10 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let no_payloads = no_payloads |> List.map (fun label -> - { - label_js = - (if is_number label then IntLabel label - else StringLabel label); - }) + { + label_js = + (if is_number label then IntLabel label else StringLabel label); + }) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads:[] ~polymorphic:true @@ -572,15 +571,14 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let payload_translations = payloads |> List.map (fun (label, payload) -> - ( label, - payload - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - )) + ( label, + payload + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env )) in let payloads = payload_translations |> List.map (fun (label, translation) -> - {case = {label_js = StringLabel label}; t = translation.type_}) + {case = {label_js = StringLabel label}; t = translation.type_}) in let type_ = create_variant ~inherits:[] ~no_payloads ~payloads ~polymorphic:true @@ -599,10 +597,9 @@ and translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env let type_equations_translation = (List.combine ids types [@doesNotRaise]) |> List.map (fun (x, t) -> - ( x, - t - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - )) + ( x, + t |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + )) in let type_equations = type_equations_translation @@ -638,53 +635,50 @@ and signature_to_module_runtime_representation ~config ~type_vars_gen ~type_env let dependencies_and_fields = signature |> List.map (fun signature_item -> - match signature_item with - | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) - | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> - let {dependencies; type_} = - type_expr - |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = Annotation.doc_string_from_attrs val_attributes; - } - in - (dependencies, [field]) - | Types.Sig_module (id, module_declaration, _recStatus) -> - let type_env1 = - match - type_env |> Type_env.get_module ~name:(id |> Ident.name) - with - | Some type_env1 -> type_env1 - | None -> type_env - in - let dependencies, type_ = - match module_declaration.md_type with - | Mty_signature signature -> - signature - |> signature_to_module_runtime_representation ~config - ~type_vars_gen ~type_env:type_env1 - | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) - in - let field = - { - mutable_ = Immutable; - name_js = id |> Ident.name; - optional = Mandatory; - type_; - doc_string = - Annotation.doc_string_from_attrs - module_declaration.md_attributes; - } - in - (dependencies, [field]) - | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> - ([], [])) + match signature_item with + | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) + | Types.Sig_value (id, {val_type = type_expr; val_attributes}) -> + let {dependencies; type_} = + type_expr + |> translateTypeExprFromTypes_ ~config ~type_vars_gen ~type_env + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = Annotation.doc_string_from_attrs val_attributes; + } + in + (dependencies, [field]) + | Types.Sig_module (id, module_declaration, _recStatus) -> + let type_env1 = + match type_env |> Type_env.get_module ~name:(id |> Ident.name) with + | Some type_env1 -> type_env1 + | None -> type_env + in + let dependencies, type_ = + match module_declaration.md_type with + | Mty_signature signature -> + signature + |> signature_to_module_runtime_representation ~config + ~type_vars_gen ~type_env:type_env1 + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) + in + let field = + { + mutable_ = Immutable; + name_js = id |> Ident.name; + optional = Mandatory; + type_; + doc_string = + Annotation.doc_string_from_attrs + module_declaration.md_attributes; + } + in + (dependencies, [field]) + | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ -> ([], [])) in let dependencies, fields = let dl, fl = dependencies_and_fields |> List.split in @@ -700,7 +694,7 @@ let translate_type_expr_from_types ~config ~type_env type_expr = if !Debug.dependencies then translation.dependencies |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string)); + Log_.item "Dependency: %s\n" (dep |> dep_to_string)); translation let translate_type_exprs_from_types ~config ~type_env type_exprs = @@ -711,7 +705,7 @@ let translate_type_exprs_from_types ~config ~type_env type_exprs = if !Debug.dependencies then translations |> List.iter (fun translation -> - translation.dependencies - |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> dep_to_string))); + translation.dependencies + |> List.iter (fun dep -> + Log_.item "Dependency: %s\n" (dep |> dep_to_string))); translations From 799f376b22686d9f440663e2c5902921b4804d23 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 29 Aug 2026 09:18:05 +0200 Subject: [PATCH 10/13] Add changelog entries for the object-representation cleanup Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4e8bdbebd8..9538d1a61c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,8 @@ - Remove the deprecated `Js` namespace and its runtime modules. https://github.com/rescript-lang/rescript/pull/8531 - Move Belt into the separately installed `@rescript/belt` package. Projects using Belt must install the package and list it in their `rescript.json` dependencies. https://github.com/rescript-lang/rescript/pull/8554 - Correct the structured function details produced by `rescript-tools doc` and exposed by `RescriptTools.Docgen`: parameters now retain labels and optionality, nested functions, tuples, variables, and generic arguments retain their type structure, return types are identified correctly, and non-function values no longer receive fake function details. This changes the published docgen detail schema. https://github.com/rescript-lang/rescript/pull/8576 +- Make object-field mutability part of the type. A property has one type for reading and writing, `obj["x"] = v` requires the field to be settable (`@set`, or an inferred open row, which the write makes settable), and a coercion never grants or widens write capability. Previously the getter type and a hidden mangled `"x#="` setter member were tracked independently, so a property could be written at a different type than it was read, and a value coerced to a type without `@set` could still be written through. https://github.com/rescript-lang/rescript/pull/8597 +- Remove the undocumented object-field attribute forms `@get` (bare or with a `null`/`undefined`/`nullable` payload) and `@set({no_get: ...})` on object types. Only bare `@set` marks a field settable; nullable getter types are written directly (`null`, `undefined`, `nullable`). https://github.com/rescript-lang/rescript/pull/8597 #### :eyeglasses: Spec Compliance @@ -30,6 +32,7 @@ #### :bug: Bug fix +- Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 - Fix signature inclusion rejecting equivalent object externals after type-alias expansion. https://github.com/rescript-lang/rescript/pull/8581 - Fix externals whose result type is an alias of `unit` so they use the same unit-return behavior as externals declared to return `unit`. https://github.com/rescript-lang/rescript/pull/8581 - Fix dynamic imports of external bindings that require FFI argument or result conversions, including `@variadic`, `@unwrap`, polymorphic variant encodings, `@as` phantom arguments, optional labeled arguments, and `@return` wrappers. The imported value now applies the same conversions as a direct external call. https://github.com/rescript-lang/rescript/pull/8582 @@ -57,6 +60,7 @@ #### :house: Internal +- Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 - Upgrade the development toolchain and primary CI builds to OCaml 5.5 while retaining OCaml 5.0 as the minimum supported version. https://github.com/rescript-lang/rescript/pull/8589 - Upgrade the vendored Flow parser from 0.267.0 to 0.320.0, the final release of the OCaml implementation. https://github.com/rescript-lang/rescript/pull/8588 - Vendor the Flow parser 0.267.0 sources used by the compiler, removing the external `flow_parser` dependency and establishing a maintained baseline for future OCaml upgrades. https://github.com/rescript-lang/rescript/pull/8587 From 4d5d3a4e3abe174763d43ebc35bcc0e6b6a21ea1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 29 Aug 2026 10:30:16 +0200 Subject: [PATCH 11/13] Fix soundness and analysis gaps found in review Four review findings on #8597, all confirmed by probe or inspection: Variance ignored field mutability. The old phantom "x#=" setter member was an arrow whose contravariant occurrence incidentally made settable fields invariant; removing the phantom left compute_variance treating every field payload with the ambient variance, so an explicitly covariant parameter could annotate a settable field and leak write capability through an abstract type. The Tfield arm now sends a Mutable field's payload through Variance.full, like a mutable record label; Immutable fields keep the ambient variance, preserving read-only covariance. Pinned by object_settable_field_covariant_param (Bad_variance). Writes instantiated polymorphic field schemes. Assigning to {@set "id": 'a. 'a => 'a} typed the value at one instance, so a monomorphic function satisfied the field while reads kept instantiating the unchanged scheme. A field's type is a scheme: reading eliminates it, writing must establish it. The write path now uses the checker's scheme-introduction discipline - fixed instantiation, typing at that instance, check_univars - extracted as type_object_field_value next to its record twin type_label_exp, returning the value at an ordinary instance as both siblings do. type_label_exp's PR#4862 retry is a label-specific completeness recovery and is deliberately not replicated; the helper's comment records that. Pinned by object_write_poly_field_less_general (Less_general) and a positive settable-poly case in object_poly_field. Along the way, instance_poly's positional boolean becomes ~fixed with a contract comment in ctype.mli: the flag controls fixed copying of polymorphic-variant rows; scheme introduction is identified by the whole operation, not by this flag. reanalyze missed Texp_object_literal. Side-effect analysis fell through to the permissive default, so a dead binding whose object literal called effectful code was classified as removable; it now checks every field expression (ObjectLiteralSideEffects deadcode case). Termination analysis crashed on the wildcard; it now compiles the literal as an ordered sequence of its fields - ordered, not unordered, because fields evaluate in source order and crediting a later field's progress past a non-returning earlier field would be unsound (the testObjectLiteralRecursionFirst case is now reported as a possible infinite loop while testObjectLiteralProgressFirst passes). Texp_object_get/Texp_object_set traverse their receiver and value instead of asserting (testObjectAccess). Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- analysis/reanalyze/src/arnold.ml | 16 +++++---- analysis/reanalyze/src/side_effects.ml | 2 ++ compiler/ml/ctype.ml | 6 ++-- compiler/ml/ctype.mli | 10 +++++- compiler/ml/typecore.ml | 36 +++++++++++++++---- compiler/ml/typedecl.ml | 12 ++++--- tests/ERROR_VARIANTS.md | 4 +-- .../deadcode/expected/deadcode.txt | 21 +++++++++-- .../deadcode/src/ObjectLiteralSideEffects.res | 4 +++ .../termination/expected/termination.txt | 34 +++++++++++++++--- .../termination/src/TestCyberTruck.res | 29 +++++++++++++++ ...ettable_field_covariant_param.res.expected | 13 +++++++ ...write_poly_field_less_general.res.expected | 12 +++++++ .../object_settable_field_covariant_param.res | 4 +++ .../object_write_poly_field_less_general.res | 8 +++++ tests/tests/src/object_poly_field.mjs | 9 +++++ tests/tests/src/object_poly_field.res | 11 ++++++ tests/tests/src/object_poly_field.resi | 3 ++ 18 files changed, 206 insertions(+), 28 deletions(-) create mode 100644 tests/analysis_tests/tests-reanalyze/deadcode/src/ObjectLiteralSideEffects.res create mode 100644 tests/build_tests/super_errors/expected/object_settable_field_covariant_param.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_write_poly_field_less_general.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_settable_field_covariant_param.res create mode 100644 tests/build_tests/super_errors/fixtures/object_write_poly_field_less_general.res diff --git a/analysis/reanalyze/src/arnold.ml b/analysis/reanalyze/src/arnold.ml index 05050c731e..3ba9e1a2e1 100644 --- a/analysis/reanalyze/src/arnold.ml +++ b/analysis/reanalyze/src/arnold.ml @@ -1003,12 +1003,16 @@ module Compile = struct | Texp_for_await_of (_id, _pat, e1, e2) -> let open Command in expression ~ctx e1 +++ expression ~ctx e2 - | Texp_object_get _ -> - not_implemented "Texp_object_get"; - assert false - | Texp_object_set _ -> - not_implemented "Texp_object_set"; - assert false + | Texp_object_literal fields -> + (* Fields are emitted and evaluated in source order *) + fields + |> List.map (fun (_name, e) -> e |> expression ~ctx) + |> Command.sequence + | Texp_object_get (e, _) -> e |> expression ~ctx + | Texp_object_set (e1, _, e2) -> + (* Receiver first, then the assigned value *) + let open Command in + expression ~ctx e1 +++ expression ~ctx e2 | Texp_letmodule _ -> not_implemented "Texp_letmodule"; assert false diff --git a/analysis/reanalyze/src/side_effects.ml b/analysis/reanalyze/src/side_effects.ml index d11bbaf9e2..03eb76ebc6 100644 --- a/analysis/reanalyze/src/side_effects.ml +++ b/analysis/reanalyze/src/side_effects.ml @@ -65,6 +65,8 @@ let rec expr_no_side_effects (expr : Typedtree.expression) = e1 |> expr_no_side_effects && e2 |> expr_no_side_effects && e3 |> expr_no_side_effects | Texp_for_of _ | Texp_for_await_of _ -> false + | Texp_object_literal fields -> + fields |> List.for_all (fun (_name, e) -> e |> expr_no_side_effects) | Texp_object_get _ -> false | Texp_object_set _ -> false | Texp_letexception (_ec, e) -> e |> expr_no_side_effects diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index df07a79e7c..3845ca86d1 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -1014,7 +1014,7 @@ let rec copy_sep fixed free bound visited ty = | _ -> copy_type_desc copy_rec ty.desc); t -let instance_poly ?(keep_names = false) fixed univars sch = +let instance_poly ?(keep_names = false) ~fixed univars sch = with_copy_session (fun () -> let univars = List.map repr univars in let copy_var ty = @@ -1035,7 +1035,7 @@ let instance_label fixed lbl = let ty_res = copy lbl.lbl_res in let vars, ty_arg = match repr lbl.lbl_arg with - | {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty + | {desc = Tpoly (ty, tl)} -> instance_poly ~fixed tl ty | _ -> ([], copy lbl.lbl_arg) in (vars, ty_arg, ty_res)) @@ -3785,7 +3785,7 @@ let rec subtype_rec env trace t1 t2 cstrs = | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> cstrs | Tpoly (u1, []), Tpoly (u2, []) -> subtype_rec env trace u1 u2 cstrs | Tpoly (u1, tl1), Tpoly (u2, []) -> - let _, u1' = instance_poly false tl1 u1 in + let _, u1' = instance_poly ~fixed:false tl1 u1 in subtype_rec env trace u1' u2 cstrs | Tpoly (u1, tl1), Tpoly (u2, tl2) -> ( try diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index f5ab08bfd8..f9ce7e424d 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -166,10 +166,18 @@ val instance_parameterized_type : val instance_declaration : type_declaration -> type_declaration val instance_poly : ?keep_names:bool -> - bool -> + fixed:bool -> type_expr list -> type_expr -> type_expr list * type_expr +(* Instantiate a scheme [Tpoly(sch, univars)]: replace the universal + variables with fresh ones and return them with the instance. [~fixed] + controls the copy of polymorphic-variant rows: a fixed copy keeps their + rows closed to further extension. Scheme *use* sites instantiate with + [~fixed:false]; scheme *introduction* sites (checking a value against + the scheme) instantiate with [~fixed:true] and then verify the value + generalizes over the returned variables ([Typecore.check_univars]) - + the introduction discipline is that whole operation, not this flag. *) (* Take an instance of a type scheme containing free univars *) val instance_label : diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 10ac4a6f76..d6f9ab1c60 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1280,7 +1280,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp match ty.desc with | Tpoly (body, tyl) -> begin_def (); - let _, ty' = instance_poly ~keep_names:true false tyl body in + let _, ty' = instance_poly ~keep_names:true ~fixed:false tyl body in end_def (); generalize ty'; let id = enter_variable lloc name ty' in @@ -2339,7 +2339,7 @@ type targs = (Asttypes.arg_label * Typedtree.expression option) list let object_field_use_type env typ = match Ctype.repr typ with | {desc = Tpoly (ty, [])} -> instance env ty - | {desc = Tpoly (ty, tl)} -> snd (instance_poly false tl ty) + | {desc = Tpoly (ty, tl)} -> snd (instance_poly ~fixed:false tl ty) | {desc = Tvar _} as ty -> let ty' = newvar () in unify env (instance_def ty) (newty (Tpoly (ty', []))); @@ -3403,8 +3403,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Error Owrite_not_mutable -> raise (Error (loc, env, Object_field_not_mutable (obj.exp_type, name))) | Ok typ -> - let typ = object_field_use_type env typ in - let value = type_expect ~context:None env svalue typ in + let value = type_object_field_value env svalue typ in rue { exp_desc = Texp_object_set (obj, name_loc, value); @@ -3981,6 +3980,31 @@ and type_label_access env srecord lid = in (record, label, opath) +(* Typing the right-hand side of an object-field assignment: the + introduction dual of [object_field_use_type]. A field's type is a scheme: + reading instantiates it, while writing must establish it, so a + polymorphic field only accepts a value at least as polymorphic — checked + by typing the value at a fixed instance and verifying it generalizes + ([instance_poly true] + [check_univars]), the same discipline as + [type_label_exp] for record labels and [type_let] for polymorphic + annotations. With no quantified variables, establishing and instantiating + the scheme coincide. [type_label_exp] additionally retries an expansive + value without type propagation (PR#4862); that is a label-specific + completeness recovery, not part of the scheme-introduction contract, and + is deliberately not replicated here. *) +and type_object_field_value env svalue typ = + match (Ctype.repr typ).desc with + | Tpoly (ty, (_ :: _ as tl)) -> + begin_def (); + let vars, ty' = instance_poly ~fixed:true tl ty in + let value = type_expect ~context:None env svalue ty' in + end_def (); + check_univars env true "field value" value typ vars; + {value with exp_type = instance env value.exp_type} + | _ -> + let typ = object_field_use_type env typ in + type_expect ~context:None env svalue typ + (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) @@ -4675,7 +4699,7 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s) | Tpoly (ty, tl) -> { pat with - pat_type = snd (instance_poly ~keep_names:true false tl ty); + pat_type = snd (instance_poly ~keep_names:true ~fixed:false tl ty); } | _ -> pat in @@ -4783,7 +4807,7 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s) match pat.pat_type.desc with | Tpoly (ty, tl) -> begin_def (); - let vars, ty' = instance_poly ~keep_names:true true tl ty in + let vars, ty' = instance_poly ~keep_names:true ~fixed:true tl ty in let exp = type_expression ty' in end_def (); check_univars env true "definition" exp pat.pat_type vars; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index bcb2e0a1d8..c962a37234 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -770,7 +770,7 @@ let rec check_constraints_rec env loc visited ty = raise (Error (loc, Constraint_failed (ty, ty'))); List.iter (check_constraints_rec env loc visited) args | Tpoly (ty, tl) -> - let _, ty = Ctype.instance_poly false tl ty in + let _, ty = Ctype.instance_poly ~fixed:false tl ty in check_constraints_rec env loc visited ty | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty) @@ -1003,7 +1003,7 @@ let check_recursion env loc path decl to_check = with Not_found -> ()); List.iter (check_regular cpath args prev_exp) args' | Tpoly (ty, tl) -> - let _, ty = Ctype.instance_poly ~keep_names:true false tl ty in + let _, ty = Ctype.instance_poly ~keep_names:true ~fixed:false tl ty in check_regular cpath args prev_exp ty | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty) in @@ -1078,8 +1078,12 @@ let compute_variance env visited vari ty = tl decl.type_variance with Not_found -> List.iter (compute_variance_rec may_inv) tl) | Tobject ty -> compute_same ty - | Tfield {typ = ty1; rest = ty2} -> - compute_same ty1; + | Tfield {mutability; typ = ty1; rest = ty2} -> + (* A settable field can be both read and written, so its payload is + an invariant occurrence, like a mutable record label. *) + (match Btype.mutability_repr mutability with + | Mutable -> compute_variance_rec Variance.full ty1 + | Immutable -> compute_same ty1); compute_same ty2 | Tsubst ty -> compute_same ty | Tvariant row -> diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 8eb91ae65b..cb4aec25ab 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -223,7 +223,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Abstract_wrong_label` | ✓ | `abstract_wrong_label.res` | Multi-arg function literal where an inner argument label doesn't match the expected arrow's label (e.g. `let f: (~a, ~b) => int = (~a, ~c) => …`). | | `Scoping_let_module` | ✓ | `scoping_let_module.res` | | | `Not_a_variant_type` | ✓ | `variant_spread_pattern_not_a_variant.res` | Pattern-level variant spread of a non-variant type. | -| `Less_general` | ✓ | `less_general_universal.res` | | +| `Less_general` | ✓ | `less_general_universal.res`, `object_write_poly_field_less_general.res` | The latter pins that assigning to a polymorphic object field checks the value against the field's scheme. | | `Modules_not_allowed` | ✓ | `super_errors_multi/Modules_not_allowed_toplevel` | Toplevel `let module(M) = …` pattern with `allow_modules=false`. | | `Cannot_infer_signature` | ✓ | `cannot_infer_signature.res` | | | `Not_a_packed_module` | ✓ | `not_a_packed_module.res` | | @@ -278,7 +278,7 @@ Type-declaration errors. Source: [typedecl.ml:27](../compiler/ml/typedecl.ml). | `Rebind_wrong_type` | ✓ | `extension_rebind_mismatch.res` | Rebinding constructor into a different extensible type fails while unifying the source constructor result with the extension target. | | `Rebind_mismatch` | ? | — | The later declaration-shape check after `Rebind_wrong_type`; no source fixture was confirmed in this pass. | | `Rebind_private` | ✓ | `extension_rebind_private.res` | Rebinding a private extension constructor as public. | -| `Bad_variance` | ✓ | `bad_variance.res`, `bad_variance_contra.res` | | +| `Bad_variance` | ✓ | `bad_variance.res`, `bad_variance_contra.res`, `object_settable_field_covariant_param.res` | The latter pins that a settable object field is an invariant occurrence, like a mutable record label. | | `Unavailable_type_constructor` | ☐ (needs build harness) | — | typedecl.ml:778. Requires a type path findable at parse time but missing during constraint enforcement; only cross-unit scenarios where a `.cmi` was found but later removed. | | `Bad_fixed_type` | ✓ | `fixed_type_no_row_variable.res` | Fully-bounded closed private polymorphic variant (`type t = private [< #A | #B > #A #B]`) satisfies `is_fixed_type` but has a static (non-`Tvar`) row. | | `Unbound_type_var_ext` | ✓ | `unbound_type_var_extension.res` | | diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt index 832dae26d7..c4efc7a2fc 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt +++ b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt @@ -1161,6 +1161,9 @@ addValueReference Newton.res:31:13 --> Newton.res:29:4 addValueReference Newton.res:31:23 --> Newton.res:29:4 addValueReference Newton.res:31:21 --> Newton.res:25:4 + Scanning ObjectLiteralSideEffects.cmt Source:ObjectLiteralSideEffects.res + addValueDeclaration +deadWithEffect ObjectLiteralSideEffects.res:3:4 path:+ObjectLiteralSideEffects + addValueDeclaration +deadNoEffect ObjectLiteralSideEffects.res:4:4 path:+ObjectLiteralSideEffects Scanning OcamlWarningSuppressToplevel.cmt Source:OcamlWarningSuppressToplevel.res addValueDeclaration +suppressed1 OcamlWarningSuppressToplevel.res:3:4 path:+OcamlWarningSuppressToplevel addValueDeclaration +suppressed2 OcamlWarningSuppressToplevel.res:4:4 path:+OcamlWarningSuppressToplevel @@ -2103,7 +2106,7 @@ Forward Liveness Analysis - decls: 744 + decls: 746 roots(external targets): 161 decl-deps: decls_with_out=451 edges_to_decls=323 @@ -3635,6 +3638,8 @@ Forward Liveness Analysis -> +Newton.+newton -> +Newton.+f -> +Newton.+fPrimed + Dead Value +ObjectLiteralSideEffects.+deadWithEffect + Dead Value +ObjectLiteralSideEffects.+deadNoEffect Live (annotated) Value +OcamlWarningSuppressToplevel.+suppressed1 Live (annotated) Value +OcamlWarningSuppressToplevel.+suppressed2 Live (annotated) Value +OcamlWarningSuppressToplevel.M.+suppressed3 @@ -5251,6 +5256,18 @@ Forward Liveness Analysis Newsyntax.res:12:24-29 record2.yy is a record label never used to read a value + Warning Dead Module + ObjectLiteralSideEffects.res:0:1 + ObjectLiteralSideEffects is a dead module as all its items are dead. + + Warning Dead Value With Side Effects + ObjectLiteralSideEffects.res:3:1-49 + deadWithEffect is never used and could have side effects + + Warning Dead Value + ObjectLiteralSideEffects.res:4:1-27 + deadNoEffect is never used + Warning Dead Type Opaque.res:2:26-41 opaqueFromRecords.A is a variant case which is never constructed @@ -5643,4 +5660,4 @@ Forward Liveness Analysis OptArg.res:14:1-42 optional argument b of function twoArgs is never used - Analysis reported 327 issues (Incorrect Dead Annotation:1, Warning Dead Exception:2, Warning Dead Module:22, Warning Dead Type:94, Warning Dead Value:178, Warning Dead Value With Side Effects:5, Warning Redundant Optional Argument:7, Warning Unused Argument:18) + Analysis reported 330 issues (Incorrect Dead Annotation:1, Warning Dead Exception:2, Warning Dead Module:23, Warning Dead Type:94, Warning Dead Value:179, Warning Dead Value With Side Effects:6, Warning Redundant Optional Argument:7, Warning Unused Argument:18) diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/src/ObjectLiteralSideEffects.res b/tests/analysis_tests/tests-reanalyze/deadcode/src/ObjectLiteralSideEffects.res new file mode 100644 index 0000000000..bfbde06b85 --- /dev/null +++ b/tests/analysis_tests/tests-reanalyze/deadcode/src/ObjectLiteralSideEffects.res @@ -0,0 +1,4 @@ +// An object literal's field expressions determine its side effects: the +// first binding must be classified with side effects, the second without. +let deadWithEffect = {"x": Console.log("effect")} +let deadNoEffect = {"x": 1} diff --git a/tests/analysis_tests/tests-reanalyze/termination/expected/termination.txt b/tests/analysis_tests/tests-reanalyze/termination/expected/termination.txt index 5852d6ee99..23df3b80a4 100644 --- a/tests/analysis_tests/tests-reanalyze/termination/expected/termination.txt +++ b/tests/analysis_tests/tests-reanalyze/termination/expected/termination.txt @@ -150,11 +150,31 @@ Termination Analysis for testTry + Function Table + 1 testObjectLiteral: +progress; testObjectLiteral + + Termination Analysis for testObjectLiteral + + Function Table + 1 testObjectLiteralProgressFirst: +progress; testObjectLiteralProgressFirst; _ + + Termination Analysis for testObjectLiteralProgressFirst + + Function Table + 1 testObjectLiteralRecursionFirst: testObjectLiteralRecursionFirst; +progress; _ + + Termination Analysis for testObjectLiteralRecursionFirst + + Function Table + 1 testObjectAccess: +progress; testObjectAccess + + Termination Analysis for testObjectAccess + Termination Analysis Stats Files:1 - Recursive Blocks:21 - Functions:49 - Infinite Loops:10 + Recursive Blocks:25 + Functions:53 + Infinite Loops:11 Hygiene Errors:2 Cache Hits:7/30 @@ -230,5 +250,11 @@ Possible infinite loop when calling countRendersCompiled CallStack: 1 countRendersCompiled (TestCyberTruck.res 283) + + Error Termination + TestCyberTruck.res:468:20-52 + Possible infinite loop when calling testObjectLiteralRecursionFirst + CallStack: + 1 testObjectLiteralRecursionFirst (TestCyberTruck.res 467) - Analysis reported 12 issues (Error Hygiene:2, Error Termination:10) + Analysis reported 13 issues (Error Hygiene:2, Error Termination:11) diff --git a/tests/analysis_tests/tests-reanalyze/termination/src/TestCyberTruck.res b/tests/analysis_tests/tests-reanalyze/termination/src/TestCyberTruck.res index 413179ad53..aa4a78b659 100644 --- a/tests/analysis_tests/tests-reanalyze/termination/src/TestCyberTruck.res +++ b/tests/analysis_tests/tests-reanalyze/termination/src/TestCyberTruck.res @@ -447,3 +447,32 @@ let rec testTry = () => { testTry() } } + +@progress(progress) +let rec testObjectLiteral = () => { + let _o = {"fst": progress(), "snd": ()} + testObjectLiteral() +} + +// Fields evaluate in source order: progress in the first field is +// established before the recursive call in the second. +@progress(progress) +let rec testObjectLiteralProgressFirst = () => { + let _o = {"fst": progress(), "snd": testObjectLiteralProgressFirst()} +} + +// The recursive call in the first field prevents the second field's +// progress from running: must be reported as an infinite loop. +@progress(progress) +let rec testObjectLiteralRecursionFirst = () => { + let _o = {"fst": testObjectLiteralRecursionFirst(), "snd": progress()} +} + +// Object reads and writes traverse their receiver and value. +@progress(progress) +let rec testObjectAccess = (o: {@set "fld": int}) => { + let _v = o["fld"] + progress() + o["fld"] = 42 + testObjectAccess(o) +} diff --git a/tests/build_tests/super_errors/expected/object_settable_field_covariant_param.res.expected b/tests/build_tests/super_errors/expected/object_settable_field_covariant_param.res.expected new file mode 100644 index 0000000000..f728121890 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_settable_field_covariant_param.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/object_settable_field_covariant_param.res:4:1-30 + + 2 │ both read and written), so a covariant parameter annotation is reject + │ ed, + 3 │ like a mutable record label. */ + 4 │ type box<+'a> = {@set "x": 'a} + 5 │ + + In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective invariant. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_write_poly_field_less_general.res.expected b/tests/build_tests/super_errors/expected/object_write_poly_field_less_general.res.expected new file mode 100644 index 0000000000..bcbcd492f7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_write_poly_field_less_general.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/object_write_poly_field_less_general.res:6:13-19 + + 4 │ type t = {@set "id": 'a. 'a => 'a} + 5 │ let f = (o: t) => { + 6 │ o["id"] = _x => 1 + 7 │ o["id"]("hello") + 8 │ } + + This field value has type int => int + which is less general than 'a. 'a => 'a \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/object_settable_field_covariant_param.res b/tests/build_tests/super_errors/fixtures/object_settable_field_covariant_param.res new file mode 100644 index 0000000000..69c1046c62 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_settable_field_covariant_param.res @@ -0,0 +1,4 @@ +/* A settable field is an invariant occurrence of its payload (it can be + both read and written), so a covariant parameter annotation is rejected, + like a mutable record label. */ +type box<+'a> = {@set "x": 'a} diff --git a/tests/build_tests/super_errors/fixtures/object_write_poly_field_less_general.res b/tests/build_tests/super_errors/fixtures/object_write_poly_field_less_general.res new file mode 100644 index 0000000000..f2e575b9e1 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_write_poly_field_less_general.res @@ -0,0 +1,8 @@ +/* Assigning to a polymorphic field checks the value against the field's + scheme: a monomorphic function must not satisfy one instance while reads + keep instantiating the unchanged scheme. */ +type t = {@set "id": 'a. 'a => 'a} +let f = (o: t) => { + o["id"] = _x => 1 + o["id"]("hello") +} diff --git a/tests/tests/src/object_poly_field.mjs b/tests/tests/src/object_poly_field.mjs index 8fbc9fb5bf..ea9984880d 100644 --- a/tests/tests/src/object_poly_field.mjs +++ b/tests/tests/src/object_poly_field.mjs @@ -23,11 +23,20 @@ let value = ({id: x => x}); let pair = use_poly(value); +function write_poly(o) { + o.id = x => x; + return [ + o.id(1), + o.id("x") + ]; +} + export { use_poly, forget_extra, use_open, value, pair, + write_poly, } /* value Not a pure module */ diff --git a/tests/tests/src/object_poly_field.res b/tests/tests/src/object_poly_field.res index 579752128b..add7304227 100644 --- a/tests/tests/src/object_poly_field.res +++ b/tests/tests/src/object_poly_field.res @@ -19,3 +19,14 @@ let use_open = (o: {.."id": 'a. 'a => 'a}) => (o["id"](1), o["id"]("x")) let value: poly = %raw(`{id: x => x}`) let pair = use_poly(value) + +/* A settable polymorphic field accepts a value as polymorphic as its + scheme, and stays usable at several types afterwards. The rejection of a + monomorphic value is pinned in + tests/build_tests/super_errors/fixtures/object_write_poly_field_less_general.res. */ +type settable_poly = {@set "id": 'a. 'a => 'a} + +let write_poly = (o: settable_poly) => { + o["id"] = x => x + (o["id"](1), o["id"]("x")) +} diff --git a/tests/tests/src/object_poly_field.resi b/tests/tests/src/object_poly_field.resi index 79d8b0ffd6..3173a121a8 100644 --- a/tests/tests/src/object_poly_field.resi +++ b/tests/tests/src/object_poly_field.resi @@ -8,3 +8,6 @@ let forget_extra: {"id": 'a. 'a => 'a, "extra": int} => poly let use_open: {.."id": 'a. 'a => 'a} => (int, string) let value: poly let pair: (int, string) + +type settable_poly = {@set "id": 'a. 'a => 'a} +let write_poly: settable_poly => (int, string) From 16afe1efd39bdc93f4ec129399cc753555c9491c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 29 Aug 2026 19:33:26 +0200 Subject: [PATCH 12/13] Require mutability backing in private-row signature inclusion The private/open-object manifest path in includecore compared paired fields by type only, so a signature could declare type t = private {..@set "x": int} over an implementation whose field was not settable - and since access follows the published row, clients could write straight through the abstraction. In the phantom-setter encoding this could not happen structurally: granting required an interface "x#=" member with no implementation partner (rejected by the missing- field check), while forgetting was the interface simply omitting the member (absorbed by the ignored implementation-side misses). Stage D turned the capability into a flag on the field, and nothing had taken over the width mechanism's job. The pairing now requires a settable implementation field wherever the interface field is settable; an implementation's settable field may still be abstracted to a read-only one. Probe-verified equivalent to the released (phantom-encoding) compiler in all directions, including that paired field types remain compared by equality - private rows allow width and capability forgetting, never depth subtyping. The @set inclusion matrix is now pinned per comparison arm, since the flag participates in several independently-changeable relations: object_private_row_grants_set (the new includecore rule), object_manifest_set_mismatch (transparent manifests are equations - eqtype), object_value_signature_set_mismatch (value signatures claim instances - moregeneral), and the legal forgetting direction compiles in object_mutability_pin.res. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01PCtQiaDijUqA2fujQXvKUw --- compiler/ml/includecore.ml | 9 ++++++ tests/ERROR_VARIANTS.md | 4 +-- .../object_manifest_set_mismatch.res.expected | 28 +++++++++++++++++++ ...object_private_row_grants_set.res.expected | 28 +++++++++++++++++++ ..._value_signature_set_mismatch.res.expected | 28 +++++++++++++++++++ .../fixtures/object_manifest_set_mismatch.res | 8 ++++++ .../object_private_row_grants_set.res | 9 ++++++ .../object_value_signature_set_mismatch.res | 9 ++++++ tests/tests/src/object_mutability_pin.mjs | 3 ++ tests/tests/src/object_mutability_pin.res | 11 ++++++++ 10 files changed, 135 insertions(+), 2 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/object_manifest_set_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_private_row_grants_set.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_value_signature_set_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_manifest_set_mismatch.res create mode 100644 tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res create mode 100644 tests/build_tests/super_errors/fixtures/object_value_signature_set_mismatch.res diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 24189819c9..577ab77173 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -137,6 +137,15 @@ let type_manifest env ty1 params1 ty2 params2 priv2 = && let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in miss2 = [] + (* The signature must not grant write capability the implementation + lacks; an implementation's settable field may be abstracted to a + read-only one. *) + && List.for_all + (fun ((f1 : Ctype.field_info), (f2 : Ctype.field_info)) -> + match Btype.mutability_repr f2.f_mut with + | Mutable -> Btype.mutability_repr f1.f_mut = Asttypes.Mutable + | Immutable -> true) + pairs && let tl1, tl2 = List.split diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index cb4aec25ab..84587e741a 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -363,7 +363,7 @@ Wrapper symptoms attached to inclusion failures. Source: [includemod.ml:23](../c | Variant | Status | Fixture | Notes | |---|---|---|---| | `Missing_field` | ✓ | `super_errors_multi/Iface_missing_value` | | -| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Iface_value_arity_mismatch`, `super_errors_multi/Smoke_interface_mismatch`, `super_errors_multi/Cross_external_spec_mismatch`, `super_errors_multi/Cross_external_payload_name`, `super_errors_multi/Cross_external_import_attrs`, `module_sig_value_arity_mismatch*.res` | Arity mismatches print a dedicated hint (implementation vs interface argument counts), including through aliases and nested function types. | +| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Iface_value_arity_mismatch`, `super_errors_multi/Smoke_interface_mismatch`, `super_errors_multi/Cross_external_spec_mismatch`, `super_errors_multi/Cross_external_payload_name`, `super_errors_multi/Cross_external_import_attrs`, `module_sig_value_arity_mismatch*.res`, `object_value_signature_set_mismatch.res` | Arity mismatches print a dedicated hint (implementation vs interface argument counts), including through aliases and nested function types. The object fixture pins that a value signature cannot drop `@set` from an object type (moregeneral requires equal field mutability). | | `Type_declarations` | ✓ | `super_errors_multi/Iface_type_decl_record`, `super_errors_multi/Iface_type_decl_variant`, `RecordInclusion.res`, `type_decl_function_arity_mismatch.res` | | | `Extension_constructors` | ✓ | `super_errors_multi/Iface_extension_constructors` | | | `Module_types` | ✓ | `super_errors_multi/Iface_module_types` | | @@ -387,7 +387,7 @@ Source: [includecore.ml:159](../compiler/ml/includecore.ml). | `Privacy` | ✓ | `super_errors_multi/Iface_privacy_mismatch` | | | `Kind` | ✓ | `super_errors_multi/Iface_kind_mismatch` | Record-in-impl vs variant-in-interface. | | `Constraint` | ✓ | `super_errors_multi/Iface_constraint_mismatch` | Implementation adds a `constraint 'a = …`; interface has none. | -| `Manifest` | ✓ | `super_errors_multi/Iface_manifest_mismatch`, `type_decl_function_arity_mismatch.res` | Manifest types differ, including function types with different arities. | +| `Manifest` | ✓ | `super_errors_multi/Iface_manifest_mismatch`, `type_decl_function_arity_mismatch.res`, `object_private_row_grants_set.res`, `object_manifest_set_mismatch.res` | Manifest types differ, including function types with different arities. The object fixtures pin the `@set` inclusion matrix: a private row's signature cannot grant `@set` its implementation lacks (but may forget it — pinned compiling in `object_mutability_pin.res`), while a transparent manifest is an equation and cannot forget it either. | | `Variance` | ✓ | `super_errors_multi/Iface_variance_mismatch` | Interface annotates `+'a`; implementation's inferred variance differs. | | `Field_type` | ✓ | `super_errors_multi/Iface_type_decl_record` | | | `Field_mutable` | ✓ | `super_errors_multi/Iface_field_mutable_mismatch` | | diff --git a/tests/build_tests/super_errors/expected/object_manifest_set_mismatch.res.expected b/tests/build_tests/super_errors/expected/object_manifest_set_mismatch.res.expected new file mode 100644 index 0000000000..39952f6333 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_manifest_set_mismatch.res.expected @@ -0,0 +1,28 @@ + + We've found a bug for you! + /.../fixtures/object_manifest_set_mismatch.res:6:5-8:1 + + 4 │ module M: { + 5 │ type t = {"x": int} + 6 │ } = { + 7 │  type t = {@set "x": int} + 8 │ } + 9 │ + + Signature mismatch: + Modules do not match: + { + type t = {@set "x": int} +} + is not included in + { + type t = {"x": int} +} + Type declarations do not match: + type t = {@set "x": int} + is not included in + type t = {"x": int} + /.../fixtures/object_manifest_set_mismatch.res:5:3-21: + Expected declaration + /.../fixtures/object_manifest_set_mismatch.res:7:3-26: + Actual declaration \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_private_row_grants_set.res.expected b/tests/build_tests/super_errors/expected/object_private_row_grants_set.res.expected new file mode 100644 index 0000000000..1d1d476ef9 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_private_row_grants_set.res.expected @@ -0,0 +1,28 @@ + + We've found a bug for you! + /.../fixtures/object_private_row_grants_set.res:7:5-9:1 + + 5 │ module M: { + 6 │ type t = private {..@set "x": int} + 7 │ } = { + 8 │  type t = private {.."x": int} + 9 │ } + 10 │ + + Signature mismatch: + Modules do not match: + { + type t = {.."x": int} +} + is not included in + { + type t = {..@set "x": int} +} + Type declarations do not match: + type t = {.."x": int} + is not included in + type t = {..@set "x": int} + /.../fixtures/object_private_row_grants_set.res:6:3-36: + Expected declaration + /.../fixtures/object_private_row_grants_set.res:8:3-31: + Actual declaration \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_value_signature_set_mismatch.res.expected b/tests/build_tests/super_errors/expected/object_value_signature_set_mismatch.res.expected new file mode 100644 index 0000000000..23c1042053 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_value_signature_set_mismatch.res.expected @@ -0,0 +1,28 @@ + + We've found a bug for you! + /.../fixtures/object_value_signature_set_mismatch.res:7:5-9:1 + + 5 │ module M: { + 6 │ let v: {"x": int} + 7 │ } = { + 8 │  let v = impl + 9 │ } + 10 │ + + Signature mismatch: + Modules do not match: + { + let v: {@set "x": int} +} + is not included in + { + let v: {"x": int} +} + Values do not match: + let v: {@set "x": int} + is not included in + let v: {"x": int} + /.../fixtures/object_value_signature_set_mismatch.res:6:3-19: + Expected declaration + /.../fixtures/object_value_signature_set_mismatch.res:8:7: + Actual declaration \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/object_manifest_set_mismatch.res b/tests/build_tests/super_errors/fixtures/object_manifest_set_mismatch.res new file mode 100644 index 0000000000..7e5cd460d9 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_manifest_set_mismatch.res @@ -0,0 +1,8 @@ +/* A transparent manifest is an equation: unlike a private row + (object_private_row_grants_set.res) or a coercion, it cannot forget a + field's @set - the flags must be equal in both directions. */ +module M: { + type t = {"x": int} +} = { + type t = {@set "x": int} +} diff --git a/tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res b/tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res new file mode 100644 index 0000000000..e4074d324f --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res @@ -0,0 +1,9 @@ +/* A signature must not grant write capability its implementation lacks: + the interface's @set field requires a settable implementation field. The + reverse direction (implementation @set abstracted to read-only) is legal + and pinned in tests/tests/src/object_mutability_pin.res. */ +module M: { + type t = private {..@set "x": int} +} = { + type t = private {.."x": int} +} diff --git a/tests/build_tests/super_errors/fixtures/object_value_signature_set_mismatch.res b/tests/build_tests/super_errors/fixtures/object_value_signature_set_mismatch.res new file mode 100644 index 0000000000..c710d6ca30 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_value_signature_set_mismatch.res @@ -0,0 +1,9 @@ +/* A value signature claims an instance of the implementation's type: + moregeneral requires equal field mutability, so an interface cannot + silently drop @set from a value's object type. */ +@val external impl: {@set "x": int} = "impl" +module M: { + let v: {"x": int} +} = { + let v = impl +} diff --git a/tests/tests/src/object_mutability_pin.mjs b/tests/tests/src/object_mutability_pin.mjs index 0fe2234126..357eacc0cf 100644 --- a/tests/tests/src/object_mutability_pin.mjs +++ b/tests/tests/src/object_mutability_pin.mjs @@ -49,6 +49,8 @@ function closed_immutable_covariant(v) { return v; } +let PrivateRowForgetsSet = {}; + export { forget_write_covariant, open_source_covariant, @@ -62,5 +64,6 @@ export { set_at_int, set_at_string, closed_immutable_covariant, + PrivateRowForgetsSet, } /* No side effect */ diff --git a/tests/tests/src/object_mutability_pin.res b/tests/tests/src/object_mutability_pin.res index d3ad46cd8d..71f7772806 100644 --- a/tests/tests/src/object_mutability_pin.res +++ b/tests/tests/src/object_mutability_pin.res @@ -58,3 +58,14 @@ let set_at_string = () => set_x(string_target, "s") /* Closed immutable-to-immutable coercion is covariant (matrix pin). */ let closed_immutable_covariant = (v: {"x": wide}): {"x": narrow} => (v :> {"x": narrow}) + +/* Private-row signature inclusion may forget write capability: the + implementation's settable field is abstracted to a read-only one. The + reverse (a signature granting @set over a plain implementation field) is + pinned as an error in + tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res. */ +module PrivateRowForgetsSet: { + type t = private {.."x": int} +} = { + type t = private {..@set "x": int} +} From a7826ab5e53f51962ff188ee9487ecfd181926c2 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sat, 29 Aug 2026 21:13:38 +0200 Subject: [PATCH 13/13] Distinguish structural and inferred object rows Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 2 +- compiler/ml/ctype.ml | 27 +++++++++++-------- compiler/ml/ctype.mli | 8 +++++- compiler/ml/printtyp.ml | 3 ++- compiler/ml/typetexp.ml | 2 +- tests/ERROR_VARIANTS.md | 2 +- .../object_private_row_write.res.expected | 11 ++++++++ ...e_row_write_through_signature.res.expected | 11 ++++++++ .../fixtures/object_private_row_write.res | 7 +++++ ...ct_private_row_write_through_signature.res | 8 ++++++ .../ounit_object_mutability_tests.ml | 27 +++++++++++++++++++ tests/tests/src/object_mutability_pin.mjs | 5 ++++ tests/tests/src/object_mutability_pin.res | 8 +++++- 13 files changed, 104 insertions(+), 17 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/object_private_row_write.res.expected create mode 100644 tests/build_tests/super_errors/expected/object_private_row_write_through_signature.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/object_private_row_write.res create mode 100644 tests/build_tests/super_errors/fixtures/object_private_row_write_through_signature.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 9538d1a61c..a01ee8ec9b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,7 +18,7 @@ - Remove the deprecated `Js` namespace and its runtime modules. https://github.com/rescript-lang/rescript/pull/8531 - Move Belt into the separately installed `@rescript/belt` package. Projects using Belt must install the package and list it in their `rescript.json` dependencies. https://github.com/rescript-lang/rescript/pull/8554 - Correct the structured function details produced by `rescript-tools doc` and exposed by `RescriptTools.Docgen`: parameters now retain labels and optionality, nested functions, tuples, variables, and generic arguments retain their type structure, return types are identified correctly, and non-function values no longer receive fake function details. This changes the published docgen detail schema. https://github.com/rescript-lang/rescript/pull/8576 -- Make object-field mutability part of the type. A property has one type for reading and writing, `obj["x"] = v` requires the field to be settable (`@set`, or an inferred open row, which the write makes settable), and a coercion never grants or widens write capability. Previously the getter type and a hidden mangled `"x#="` setter member were tracked independently, so a property could be written at a different type than it was read, and a value coerced to a type without `@set` could still be written through. https://github.com/rescript-lang/rescript/pull/8597 +- Make object-field mutability part of the type. A property has one type for reading and writing. Assignment requires `@set`, except on an inferred open row, where assignment makes the field settable. Private rows are not inferred open rows, so a field in `type t = private {.."x": int}` is writable only when annotated with `@set`. Coercions never grant or widen write capability. Previously, getter and setter types were tracked independently, allowing a property to be written at a different type than it was read and allowing writes through a value coerced to a type without `@set`. https://github.com/rescript-lang/rescript/pull/8597 - Remove the undocumented object-field attribute forms `@get` (bare or with a `null`/`undefined`/`nullable` payload) and `@set({no_get: ...})` on object types. Only bare `@set` marks a field settable; nullable getter types are written directly (`null`, `undefined`, `nullable`). https://github.com/rescript-lang/rescript/pull/8597 #### :eyeglasses: Spec Compliance diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 3845ca86d1..71cf1b5b3b 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -316,7 +316,7 @@ let rec object_row ty = | Tfield {rest = t} -> object_row t | _ -> ty -let opened_object ty = +let object_row_is_structurally_open ty = match (object_row ty).desc with | Tvar _ | Tunivar _ | Tconstr _ -> true | _ -> false @@ -2648,13 +2648,17 @@ type object_field_write_error = Owrite_missing | Owrite_not_mutable (* Look up [name] for assignment in the object type [ty]. - A [Mutable] field yields its type. - - An [Immutable] field is promoted iff the object row is open; on a - closed row the write is rejected. - - An absent field is added as [Mutable] through an open row; on a closed - row the write is rejected as missing. *) + - An [Immutable] field is promoted iff the row ends in a [Tvar], the + same predicate [unify_mutability] uses. + [object_row_is_structurally_open] also holds for rigid [Tunivar] and + private-row [Tconstr] terminators. It cannot therefore gate promotion; + in particular, ordinary copies of a private row share the declaration's + mutability cell, so a write would later be saved as [@set] in the .cmi. + - An absent field is added as [Mutable] through a [Tvar] rest; on a + closed or private row the write is rejected as missing. *) let filter_object_field_for_write env name ty : (type_expr, object_field_write_error) Result.t = - let rec write_field ~opened ty = + let rec write_field ~can_promote ty = let ty = expand_head_trace env ty in match ty.desc with | Tvar _ -> @@ -2677,13 +2681,13 @@ let filter_object_field_for_write env name ty : match mutability_repr mutability with | Asttypes.Mutable -> Ok typ | Immutable -> - if opened then ( + if can_promote then ( set_mutability (mutability_ref_repr mutability) (Mutability_value Asttypes.Mutable); Ok typ) else Error Owrite_not_mutable - else write_field ~opened f.rest + else write_field ~can_promote f.rest | _ -> Error Owrite_missing in let ty = expand_head_trace env ty in @@ -2693,8 +2697,8 @@ let filter_object_field_for_write env name ty : let ty' = newobj ty1 in update_level env ty.level ty'; link_type ty ty'; - write_field ~opened:true ty1 - | Tobject f -> write_field ~opened:(opened_object ty) f + write_field ~can_promote:true ty1 + | Tobject f -> write_field ~can_promote:(is_Tvar (object_row ty)) f | _ -> Error Owrite_missing (* Unify [ty] and [{.. name: 'a}]. Return ['a]. *) @@ -3347,7 +3351,8 @@ let rec build_subtype env visited loops posi level t = in (newty (Tvariant row), Changed) | Tobject t1 -> - if memq_warn t visited || opened_object t1 then (t, Unchanged) + if memq_warn t visited || object_row_is_structurally_open t1 then + (t, Unchanged) else let level' = pred_enlarge level in let visited = diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index f9ce7e424d..0d008f7239 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -117,7 +117,13 @@ val flatten_fields : type_expr -> fields * type_expr (* Transform a field type into a sorted list of field infos *) val associate_fields : fields -> fields -> (field_info * field_info) list * fields * fields -val opened_object : type_expr -> bool + +val object_row_is_structurally_open : type_expr -> bool +(** Whether an object row is structurally open: its terminator is a [Tvar], + [Tunivar], or [Tconstr], rather than [Tnil]. This does not imply that the + row can be strengthened. Row-strengthening operations that add a field or + promote field mutability require a [Tvar] terminator. *) + val lid_of_path : ?hash:string -> Path.t -> Longident.t val sort_row_fields : (label * row_field) list -> (label * row_field) list diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 74eb7883e1..b878e6f7ed 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -501,7 +501,8 @@ let rec mark_loops_rec visited ty = | Tobject fi -> if List.memq px !visited_objects then add_alias px else ( - if opened_object ty then visited_objects := px :: !visited_objects; + if object_row_is_structurally_open ty then + visited_objects := px :: !visited_objects; let fields, _ = flatten_fields fi in List.iter (fun {Ctype.f_typ} -> mark_loops_rec visited f_typ) fields) | Tfield {typ = ty1; rest = ty2} -> diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index c5d9999f34..d72edc9900 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -610,7 +610,7 @@ and transl_fields env policy o fields = let t = expand_head env cty.ctyp_type in match (t, nm) with | {desc = Tobject {desc = (Tfield _ | Tnil) as tf}}, _ -> - if opened_object t then + if object_row_is_structurally_open t then raise (Error (sty.ptyp_loc, env, Opened_object nm)); let rec iter_add = function | Tfield {name = s; mutability; typ = ty1; rest = ty2} -> diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 84587e741a..0c57b4748d 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -216,7 +216,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Wrong_name` | ✓ | `wrong_name_record_field.res`, `Cross_record_extra_field` (multi) | | | `Name_type_mismatch` | ✓ | `super_errors_multi/Cross_qualified_constructor_mismatch` | Cross-module constructor disambiguation. | | `Undefined_method` | ✓ | `super_errors_multi/Cross_module_alias_dot_access`, `undefined_method` | | -| `Object_field_not_mutable` | ✓ | `object_write_closed_row`, `object_write_alias`, `object_write_after_forgetting` | Assignment to a field without `@set`; the latter two pin that promotion is per equivalence class (an alias write strengthens the shared constraint) and that a coercion never grants write capability. | +| `Object_field_not_mutable` | ✓ | `object_write_closed_row`, `object_write_alias`, `object_write_after_forgetting`, `object_private_row_write`, `object_private_row_write_through_signature` | Assignment to a field without `@set`. `object_write_alias` pins that promotion is per equivalence class, and `object_write_after_forgetting` pins that a coercion never grants write capability. The private-row fixtures pin that a `Tconstr` row terminator is structurally open but cannot be strengthened: writing through `type t = private {.."x": int}` (directly or via a signature) is rejected, matching `unify_mutability`. | | `Private_type` | ✓ | `private_type_construction.res` | | | `Private_label` | ✓ | `private_label.res` | | | `Not_subtype` | ✓ | `subtype_*.res`, `coercion_arity_mismatch.res`, `dict_show_no_coercion.res`, etc. | | diff --git a/tests/build_tests/super_errors/expected/object_private_row_write.res.expected b/tests/build_tests/super_errors/expected/object_private_row_write.res.expected new file mode 100644 index 0000000000..e4f084b256 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_private_row_write.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/object_private_row_write.res:7:23-32 + + 5 │ pinned in tests/tests/src/object_mutability_pin.res. */ + 6 │ type t = private {.."x": int} + 7 │ let write = (o: t) => o["x"] = 1 + 8 │ + + This expression has type t + The field x is not settable. Only fields annotated with @set, e.g. {@set "x": int}, can be assigned. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/object_private_row_write_through_signature.res.expected b/tests/build_tests/super_errors/expected/object_private_row_write_through_signature.res.expected new file mode 100644 index 0000000000..f1fdf4f316 --- /dev/null +++ b/tests/build_tests/super_errors/expected/object_private_row_write_through_signature.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/object_private_row_write_through_signature.res:8:26-35 + + 6 │ type t = private {.."x": int} + 7 │ } + 8 │ let mutate = (o: M.t) => o["x"] = 1 + 9 │ + + This expression has type M.t + The field x is not settable. Only fields annotated with @set, e.g. {@set "x": int}, can be assigned. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/object_private_row_write.res b/tests/build_tests/super_errors/fixtures/object_private_row_write.res new file mode 100644 index 0000000000..abeec08076 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_private_row_write.res @@ -0,0 +1,7 @@ +/* A private row is not an inferred open row: writing a field that is + not @set must be rejected. The Tconstr terminator shares the + declaration's mutability cell, so a successful write would persist + @set into the .cmi. The compiling counterpart (private {..@set}) is + pinned in tests/tests/src/object_mutability_pin.res. */ +type t = private {.."x": int} +let write = (o: t) => o["x"] = 1 diff --git a/tests/build_tests/super_errors/fixtures/object_private_row_write_through_signature.res b/tests/build_tests/super_errors/fixtures/object_private_row_write_through_signature.res new file mode 100644 index 0000000000..6b1d6ecddd --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/object_private_row_write_through_signature.res @@ -0,0 +1,8 @@ +/* Dual of object_private_row_grants_set.res: a signature that does not + grant @set cannot be written through from outside the module. */ +module M: { + type t = private {.."x": int} +} = { + type t = private {.."x": int} +} +let mutate = (o: M.t) => o["x"] = 1 diff --git a/tests/ounit_tests/ounit_object_mutability_tests.ml b/tests/ounit_tests/ounit_object_mutability_tests.ml index 335da3ca34..7d97b038b6 100644 --- a/tests/ounit_tests/ounit_object_mutability_tests.ml +++ b/tests/ounit_tests/ounit_object_mutability_tests.ml @@ -378,6 +378,31 @@ let test_for_saving_copy_order_is_irrelevant _ = "copying owners of one class must not depend on their order in the session" (source_first_shares = saved_first_shares) +let private_row_obj cell = + let rest = + Ctype.newty + (Types.Tconstr (Path.Pident (Ident.create "t#row"), [], ref Types.Mnil)) + in + Ctype.newobj + (Ctype.newty + (Types.Tfield {name = "x"; mutability = cell; typ = int_typ (); rest})) + +let test_private_row_write_does_not_promote _ = + (* Structural openness includes a [Tconstr] terminator, but assignment must + use the same [Tvar] gate as [unify_mutability]: copies share this cell + with the declaration. *) + let cell = immutable_cell () in + let ty = private_row_obj cell in + assert_bool "the private row is structurally open" + (Ctype.object_row_is_structurally_open ty); + (match Ctype.filter_object_field_for_write Env.empty "x" ty with + | Error Ctype.Owrite_not_mutable -> () + | Error Ctype.Owrite_missing -> + OUnit.assert_failure "expected not-mutable, got missing" + | Ok _ -> OUnit.assert_failure "private-row write should be rejected"); + assert_bool "the declaration cell is untouched" + (Btype.mutability_repr cell = Asttypes.Immutable) + let test_for_saving_fresh_copy_preserves_internal_aliasing _ = Ctype.begin_def (); let cell = immutable_cell () in @@ -435,4 +460,6 @@ let suites = >:: test_for_saving_copy_order_is_irrelevant; "for_saving_fresh_copy_preserves_internal_aliasing" >:: test_for_saving_fresh_copy_preserves_internal_aliasing; + "private_row_write_does_not_promote" + >:: test_private_row_write_does_not_promote; ] diff --git a/tests/tests/src/object_mutability_pin.mjs b/tests/tests/src/object_mutability_pin.mjs index 357eacc0cf..e202d5808d 100644 --- a/tests/tests/src/object_mutability_pin.mjs +++ b/tests/tests/src/object_mutability_pin.mjs @@ -51,6 +51,10 @@ function closed_immutable_covariant(v) { let PrivateRowForgetsSet = {}; +function write_private_settable(o) { + o.x = 1; +} + export { forget_write_covariant, open_source_covariant, @@ -65,5 +69,6 @@ export { set_at_string, closed_immutable_covariant, PrivateRowForgetsSet, + write_private_settable, } /* No side effect */ diff --git a/tests/tests/src/object_mutability_pin.res b/tests/tests/src/object_mutability_pin.res index 71f7772806..2946e392ce 100644 --- a/tests/tests/src/object_mutability_pin.res +++ b/tests/tests/src/object_mutability_pin.res @@ -63,9 +63,15 @@ let closed_immutable_covariant = (v: {"x": wide}): {"x": narrow} => (v :> {"x": implementation's settable field is abstracted to a read-only one. The reverse (a signature granting @set over a plain implementation field) is pinned as an error in - tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res. */ + tests/build_tests/super_errors/fixtures/object_private_row_grants_set.res. + Writing a private row that already has @set is accepted; writing a + private readonly row is pinned as an error in + object_private_row_write.res. */ module PrivateRowForgetsSet: { type t = private {.."x": int} } = { type t = private {..@set "x": int} } + +type private_settable = private {..@set "x": int} +let write_private_settable = (o: private_settable) => o["x"] = 1