From 09be8ce7a562ad0347ccd63a8973b87df51de80c Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Tue, 27 Oct 2026 12:39:54 +0000 Subject: [PATCH] Test GADTs and other OCaml-derived type and module features GADTs, existentials, polymorphic record fields, constraint, private and indexed extensible types, destructive substitution and typed first-class modules had no behavioural tests. Part of #9074. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gLMawVgtmiKy3TMBc3 Claude-Session: https://claude.ai/code/session_01Kr4cjoUi2f5VpMvE6wT9bo Signed-off-by: Christoph Knittel --- ...without_locally_abstract_type.res.expected | 15 + ..._recursion_without_annotation.res.expected | 13 + ...dt_match_without_locally_abstract_type.res | 7 + ...lymorphic_recursion_without_annotation.res | 7 + tests/tests/src/advanced_types_test.mjs | 318 ++++++++++++ tests/tests/src/advanced_types_test.res | 201 ++++++++ tests/tests/src/extensible_variant_test.mjs | 121 ++++- tests/tests/src/extensible_variant_test.res | 91 ++++ tests/tests/src/gadt_test.mjs | 475 ++++++++++++++++++ tests/tests/src/gadt_test.res | 261 ++++++++++ 10 files changed, 1506 insertions(+), 3 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/gadt_match_without_locally_abstract_type.res.expected create mode 100644 tests/build_tests/super_errors/expected/polymorphic_recursion_without_annotation.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/gadt_match_without_locally_abstract_type.res create mode 100644 tests/build_tests/super_errors/fixtures/polymorphic_recursion_without_annotation.res create mode 100644 tests/tests/src/advanced_types_test.mjs create mode 100644 tests/tests/src/advanced_types_test.res create mode 100644 tests/tests/src/gadt_test.mjs create mode 100644 tests/tests/src/gadt_test.res diff --git a/tests/build_tests/super_errors/expected/gadt_match_without_locally_abstract_type.res.expected b/tests/build_tests/super_errors/expected/gadt_match_without_locally_abstract_type.res.expected new file mode 100644 index 00000000000..bfc7b506826 --- /dev/null +++ b/tests/build_tests/super_errors/expected/gadt_match_without_locally_abstract_type.res.expected @@ -0,0 +1,15 @@ + + We've found a bug for you! + /.../fixtures/gadt_match_without_locally_abstract_type.res:6:5 + + 4 ┆ switch x { + 5 ┆ | I => 1 + 6 ┆ | S => "s" + 7 ┆ } + 8 ┆ + + This pattern matches values of type t + but a pattern was expected which matches values of type t + + The incompatible parts: + string vs int \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/polymorphic_recursion_without_annotation.res.expected b/tests/build_tests/super_errors/expected/polymorphic_recursion_without_annotation.res.expected new file mode 100644 index 00000000000..8e30d8a3b15 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polymorphic_recursion_without_annotation.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/polymorphic_recursion_without_annotation.res:6:26 + + 4 ┆ switch n { + 5 ┆ | Flat(_) => 0 + 6 ┆ | Nest(n) => 1 + depth(n) + 7 ┆ } + 8 ┆ + + This has type: nested> + But this function argument is expecting: nested<'a> + The type variable 'a occurs inside array<'a> \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/gadt_match_without_locally_abstract_type.res b/tests/build_tests/super_errors/fixtures/gadt_match_without_locally_abstract_type.res new file mode 100644 index 00000000000..864c43bb835 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/gadt_match_without_locally_abstract_type.res @@ -0,0 +1,7 @@ +type rec t<_> = I: t | S: t + +let f = x => + switch x { + | I => 1 + | S => "s" + } diff --git a/tests/build_tests/super_errors/fixtures/polymorphic_recursion_without_annotation.res b/tests/build_tests/super_errors/fixtures/polymorphic_recursion_without_annotation.res new file mode 100644 index 00000000000..dfd834f6ca3 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polymorphic_recursion_without_annotation.res @@ -0,0 +1,7 @@ +type rec nested<'a> = Flat('a) | Nest(nested>) + +let rec depth = n => + switch n { + | Flat(_) => 0 + | Nest(n) => 1 + depth(n) + } diff --git a/tests/tests/src/advanced_types_test.mjs b/tests/tests/src/advanced_types_test.mjs new file mode 100644 index 00000000000..53289cb1709 --- /dev/null +++ b/tests/tests/src/advanced_types_test.mjs @@ -0,0 +1,318 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Stdlib_Int from "@rescript/runtime/lib/es6/Stdlib_Int.mjs"; +import * as Test_utils from "./test_utils.mjs"; +import * as Stdlib_Option from "@rescript/runtime/lib/es6/Stdlib_Option.mjs"; +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +function useIdentity(param) { + let id = param.id; + return [ + id(1), + id("s") + ]; +} + +let arrayMapper = { + map: (xs, f) => xs.map(f) +}; + +function singleton(x) { + return [x]; +} + +let withDefault_1 = [2]; + +let withDefault = [ + 1, + withDefault_1 +]; + +function sum(l) { + if (typeof l !== "object") { + return 0; + } + let match = l.VAL; + return match[0] + sum(match[1]) | 0; +} + +function keep(x) { + return x; +} + +function describeColor(c) { + if (c === "Blue") { + return "blue"; + } else { + return "basic " + c; + } +} + +function make(n) { + if (n > 0) { + return n; + } +} + +let Positive = { + make: make +}; + +function parse(s) { + let n = Stdlib_Int.fromString(s); + if (n !== undefined) { + return { + TAG: "Number", + _0: n + }; + } else { + return { + TAG: "Word", + _0: s + }; + } +} + +let Token = { + parse: parse +}; + +function make$1(x) { + return Primitive_option.some(x); +} + +function get(x) { + return Stdlib_Option.getOrThrow(x, undefined); +} + +let Box = { + make: make$1, + get: get +}; + +let widened = "A"; + +function make$2(x) { + return [x]; +} + +function toArray(t) { + return t; +} + +let IntContainer = { + make: make$2, + toArray: toArray +}; + +function compare(a, b) { + return a - b | 0; +} + +let IntOrd = { + compare: compare +}; + +function max(a, b) { + if ((a - b | 0) > 0) { + return a; + } else { + return b; + } +} + +let IntMax = { + O: IntOrd, + max: max +}; + +function Apply(F) { + return X => F(X); +} + +function Reverse(X) { + let compare = (a, b) => X.compare(b, a); + return { + compare: compare + }; +} + +function compare$1(a, b) { + return b - a | 0; +} + +let ReverseInt = { + compare: compare$1 +}; + +function Counter($star) { + let count = { + contents: 0 + }; + let next = () => { + count.contents = count.contents + 1 | 0; + return count.contents; + }; + return { + count: count, + next: next + }; +} + +let count = { + contents: 0 +}; + +function next() { + count.contents = count.contents + 1 | 0; + return count.contents; +} + +let Counter1 = { + count: count, + next: next +}; + +let count$1 = { + contents: 0 +}; + +function next$1() { + count$1.contents = count$1.contents + 1 | 0; + return count$1.contents; +} + +let Counter2 = { + count: count$1, + next: next$1 +}; + +function showValue(m) { + return m.show(m.value); +} + +function valueOf(m) { + return m.value; +} + +function show(n) { + return n.toString(); +} + +let IntValue = { + value: 3, + show: show +}; + +Mocha.describe("Advanced_types_test", () => { + Mocha.test("polymorphic fields", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 144, characters 7-14", [ + 1, + "s" + ], useIdentity({ + id: x => x + })); + Test_utils.eq("File \"advanced_types_test.res\", line 146, characters 6-13", [ + [2], + ["a!"] + ], [ + arrayMapper.map([1], x => x + 1 | 0), + arrayMapper.map(["a"], s => s + "!") + ]); + Test_utils.eq("File \"advanced_types_test.res\", line 150, characters 7-14", [ + [1], + ["a"] + ], [ + [1], + ["a"] + ]); + }); + Mocha.test("constraint and alias", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 154, characters 7-14", [ + 1, + [2] + ], withDefault); + Test_utils.eq("File \"advanced_types_test.res\", line 155, characters 7-14", 3, sum({ + NAME: "Cons", + VAL: [ + 1, + { + NAME: "Cons", + VAL: [ + 2, + "Nil" + ] + } + ] + })); + Test_utils.eq("File \"advanced_types_test.res\", line 156, characters 7-14", "B", "B"); + }); + Mocha.test("type pattern", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 160, characters 7-14", "basic Red", "basic Red"); + Test_utils.eq("File \"advanced_types_test.res\", line 161, characters 7-14", "blue", "blue"); + }); + Mocha.test("private types", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 166, characters 20-27", 4, 3 + 1 | 0); + Test_utils.eq("File \"advanced_types_test.res\", line 169, characters 7-14", undefined, undefined); + let n = parse("7"); + let tmp; + tmp = n.TAG === "Word" ? 0 : n._0; + Test_utils.eq("File \"advanced_types_test.res\", line 171, characters 6-13", 7, tmp); + }); + Mocha.test("variance", () => Test_utils.eq("File \"advanced_types_test.res\", line 181, characters 7-14", "A", Stdlib_Option.getOrThrow(widened, undefined))); + Mocha.test("signatures", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 185, characters 7-14", [1], [1]); + Test_utils.eq("File \"advanced_types_test.res\", line 186, characters 7-14", 9, 9); + Test_utils.eq("File \"advanced_types_test.res\", line 187, characters 7-14", 2, 2); + }); + Mocha.test("functors", () => { + Test_utils.ok("File \"advanced_types_test.res\", line 191, characters 7-14", compare$1(1, 2) > 0); + Test_utils.eq("File \"advanced_types_test.res\", line 192, characters 7-14", 1, next()); + Test_utils.eq("File \"advanced_types_test.res\", line 193, characters 7-14", 2, next()); + Test_utils.eq("File \"advanced_types_test.res\", line 194, characters 7-14", 1, next$1()); + }); + Mocha.test("first-class modules", () => { + Test_utils.eq("File \"advanced_types_test.res\", line 198, characters 7-14", "3", (3).toString()); + Test_utils.eq("File \"advanced_types_test.res\", line 199, characters 7-14", 3, 3); + }); +}); + +let IntOrdCopy = IntOrd; + +let Positive$make = make; + +let Box$make = make$1; + +let IntContainer$make = make$2; + +export { + useIdentity, + arrayMapper, + singleton, + withDefault, + sum, + keep, + describeColor, + Positive, + Token, + Box, + widened, + IntContainer, + IntOrd, + IntMax, + IntOrdCopy, + Apply, + Reverse, + ReverseInt, + Counter, + Counter1, + Counter2, + showValue, + valueOf, + IntValue, + Positive$make, + Box$make, + IntContainer$make, +} +/* Not a pure module */ diff --git a/tests/tests/src/advanced_types_test.res b/tests/tests/src/advanced_types_test.res new file mode 100644 index 00000000000..e096635685b --- /dev/null +++ b/tests/tests/src/advanced_types_test.res @@ -0,0 +1,201 @@ +open Mocha +open Test_utils + +// Polymorphic record fields: the field stays polymorphic at every use. +type identity = {id: 'a. 'a => 'a} +let useIdentity = ({id}) => (id(1), id("s")) + +type mapper = {map: 'a 'b. (array<'a>, 'a => 'b) => array<'b>} +let arrayMapper = {map: (xs, f) => xs->Array.map(f)} + +// Explicitly polymorphic let binding. +let singleton: 'a. 'a => array<'a> = x => [x] + +// `constraint` ties type parameters together. +type withDefault<'a, 'b> = ('a, 'b) constraint 'b = array<'a> +let withDefault: withDefault = (1, [2]) + +// `as 'a` names a type inside the annotation. +type rec intList = [#Nil | #Cons(int, intList)] +let rec sum = (l: intList) => + switch l { + | #Nil => 0 + | #Cons(n, rest) => n + sum(rest) + } +let keep = (x: [#A | #B] as 'a): 'a => x + +// `#...t` matches every constructor of a polymorphic variant type. +type basic = [#Red | #Green] +type color = [basic | #Blue] +let describeColor = (c: color) => + switch c { + | #...basic as b => "basic " ++ ((b: basic) :> string) + | #Blue => "blue" + } + +// Private types: readable from outside, constructed only inside. +module Positive: { + type t = private int + let make: int => option +} = { + type t = int + let make = n => n > 0 ? Some(n) : None +} + +module Token: { + type t = private Word(string) | Number(int) + let parse: string => t +} = { + type t = Word(string) | Number(int) + let parse = s => + switch Int.fromString(s) { + | Some(n) => Number(n) + | None => Word(s) + } +} + +// Variance annotations allow coercing an abstract type. +module Box: { + type t<+'a> + let make: 'a => t<'a> + let get: t<'a> => 'a +} = { + type t<'a> = option<'a> + let make = x => Some(x) + let get = x => x->Option.getOrThrow +} +let widened: Box.t<[#A | #B]> = (Box.make(#A) :> Box.t<[#A | #B]>) + +// Destructive substitution removes a type from a signature. +module type Container = { + type elt + type t + let make: elt => t + let toArray: t => array +} +module type IntContainer = Container with type elt := int +module IntContainer: IntContainer = { + type t = array + let make = x => [x] + let toArray = t => t +} + +// `with module` and `module type of`. +module type Ord = { + type t + let compare: (t, t) => int +} +module IntOrd = { + type t = int + let compare = (a: int, b) => a - b +} +module type HasOrd = { + module O: Ord + let max: (O.t, O.t) => O.t +} +module IntMax: HasOrd with module O = IntOrd = { + module O = IntOrd + let max = (a, b) => O.compare(a, b) > 0 ? a : b +} +module type IntOrdType = module type of IntOrd +module IntOrdCopy: IntOrdType = IntOrd + +// Higher-order and generative functors. +module type MakeOrd = (X: Ord) => Ord +module Apply = (F: MakeOrd, X: Ord) => F(X) +module Reverse = (X: Ord) => { + type t = X.t + let compare = (a, b) => X.compare(b, a) +} +module ReverseInt = Apply(Reverse, IntOrd) + +module Counter = () => { + let count = ref(0) + let next = () => { + count := count.contents + 1 + count.contents + } +} +module Counter1 = Counter() +module Counter2 = Counter() + +// First-class modules with a type parameter. +module type Value = { + type t + let value: t + let show: t => string +} +let showValue = (type a, m: module(Value with type t = a)) => { + module V = unpack(m) + V.show(V.value) +} +let valueOf = (type a, m: module(Value with type t = a)): a => { + module V = unpack(m) + V.value +} +module IntValue = { + type t = int + let value = 3 + let show = n => Int.toString(n) +} + +describe(__MODULE__, () => { + test("polymorphic fields", () => { + eq(__LOC__, (1, "s"), useIdentity({id: x => x})) + eq( + __LOC__, + ([2], ["a!"]), + (arrayMapper.map([1], x => x + 1), arrayMapper.map(["a"], s => s ++ "!")), + ) + eq(__LOC__, ([1], ["a"]), (singleton(1), singleton("a"))) + }) + + test("constraint and alias", () => { + eq(__LOC__, (1, [2]), withDefault) + eq(__LOC__, 3, sum(#Cons(1, #Cons(2, #Nil)))) + eq(__LOC__, #B, keep(#B)) + }) + + test("type pattern", () => { + eq(__LOC__, "basic Red", describeColor(#Red)) + eq(__LOC__, "blue", describeColor(#Blue)) + }) + + test("private types", () => { + switch Positive.make(3) { + | Some(p) => eq(__LOC__, 4, (p :> int) + 1) + | None => ok(__LOC__, false) + } + eq(__LOC__, None, Positive.make(0)) + eq( + __LOC__, + 7, + switch Token.parse("7") { + | Number(n) => n + | Word(_) => 0 + }, + ) + }) + + test("variance", () => { + eq(__LOC__, #A, Box.get(widened)) + }) + + test("signatures", () => { + eq(__LOC__, [1], IntContainer.make(1)->IntContainer.toArray) + eq(__LOC__, 9, IntMax.max(3, 9)) + eq(__LOC__, 2, IntOrdCopy.compare(5, 3)) + }) + + test("functors", () => { + ok(__LOC__, ReverseInt.compare(1, 2) > 0) + eq(__LOC__, 1, Counter1.next()) + eq(__LOC__, 2, Counter1.next()) + eq(__LOC__, 1, Counter2.next()) + }) + + test("first-class modules", () => { + eq(__LOC__, "3", showValue(module(IntValue))) + eq(__LOC__, 3, valueOf(module(IntValue))) + }) +}) diff --git a/tests/tests/src/extensible_variant_test.mjs b/tests/tests/src/extensible_variant_test.mjs index c8d8a68325b..15e36b1c2a3 100644 --- a/tests/tests/src/extensible_variant_test.mjs +++ b/tests/tests/src/extensible_variant_test.mjs @@ -2,6 +2,7 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; +import * as Primitive_object from "@rescript/runtime/lib/es6/Primitive_object.mjs"; import * as Primitive_exceptions from "@rescript/runtime/lib/es6/Primitive_exceptions.mjs"; let Str = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.Str"); @@ -35,27 +36,141 @@ function to_int(x) { }; } +let Point = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.Point"); + +let IntKey = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.IntKey"); + +let StringKey = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.StringKey"); + +function defaultOf(key) { + if (key.RE_EXN_ID === IntKey) { + return 0; + } else if (key.RE_EXN_ID === StringKey) { + return ""; + } else { + return; + } +} + +let A = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.Private.A"); + +let B = /* @__PURE__ */Primitive_exceptions.create("Extensible_variant_test.Private.B"); + +let b = { + RE_EXN_ID: B +}; + +let Private = { + A: A, + b: b +}; + +function privateName(t) { + if (t.RE_EXN_ID === A) { + return "A"; + } else { + return "other"; + } +} + +function makeException() { + let Local = /* @__PURE__ */Primitive_exceptions.create("Local"); + let raise = () => { + throw { + RE_EXN_ID: Local, + Error: new Error() + }; + }; + let isLocal = exn => exn.RE_EXN_ID === Local; + return [ + raise, + isLocal + ]; +} + Mocha.describe("Extensible_variant_test", () => { - Mocha.test("test_int", () => Test_utils.eq("File \"extensible_variant_test.res\", line 24, characters 7-14", 3, to_int({ + Mocha.test("test_int", () => Test_utils.eq("File \"extensible_variant_test.res\", line 73, characters 7-14", 3, to_int({ RE_EXN_ID: Int, _1: 3, _2: 0 }))); - Mocha.test("test_int2", () => Test_utils.eq("File \"extensible_variant_test.res\", line 28, characters 7-14", 0, to_int({ + Mocha.test("test_int2", () => Test_utils.eq("File \"extensible_variant_test.res\", line 77, characters 7-14", 0, to_int({ RE_EXN_ID: Int$1, _1: 3, _2: 0 }))); - Mocha.test("test_string", () => Test_utils.eq("File \"extensible_variant_test.res\", line 32, characters 7-14", -1, to_int({ + Mocha.test("test_string", () => Test_utils.eq("File \"extensible_variant_test.res\", line 81, characters 7-14", -1, to_int({ RE_EXN_ID: Str, _1: "x" }))); + Mocha.test("inline record", () => { + let point = { + RE_EXN_ID: Point, + "x-coord": 1, + y: 2 + }; + Test_utils.eq("File \"extensible_variant_test.res\", line 86, characters 7-14", 1, point["x-coord"]); + Test_utils.eq("File \"extensible_variant_test.res\", line 88, characters 6-13", 3, Point === Point ? 3 : 0); + }); + Mocha.test("rebind", () => { + Test_utils.eq("File \"extensible_variant_test.res\", line 98, characters 7-14", -1, to_int({ + RE_EXN_ID: Str, + _1: "x" + })); + Test_utils.eq("File \"extensible_variant_test.res\", line 99, characters 7-14", true, Primitive_object.equal({ + RE_EXN_ID: Str, + _1: "x" + }, { + RE_EXN_ID: Str, + _1: "x" + })); + }); + Mocha.test("indexed extension", () => { + Test_utils.eq("File \"extensible_variant_test.res\", line 103, characters 7-14", 0, defaultOf({ + RE_EXN_ID: IntKey + })); + Test_utils.eq("File \"extensible_variant_test.res\", line 104, characters 7-14", "", defaultOf({ + RE_EXN_ID: StringKey + })); + }); + Mocha.test("private extensible", () => { + Test_utils.eq("File \"extensible_variant_test.res\", line 108, characters 7-14", "A", privateName({ + RE_EXN_ID: A + })); + Test_utils.eq("File \"extensible_variant_test.res\", line 109, characters 7-14", "other", privateName(b)); + }); + Mocha.test("local exceptions are generative", () => { + let match = makeException(); + let match$1 = makeException(); + let caught; + try { + caught = match[0](); + } catch (raw_exn) { + caught = Primitive_exceptions.internalToException(raw_exn); + } + if (caught !== undefined) { + Test_utils.eq("File \"extensible_variant_test.res\", line 120, characters 9-16", true, match[1](caught)); + return Test_utils.eq("File \"extensible_variant_test.res\", line 121, characters 9-16", false, match$1[1](caught)); + } else { + return Test_utils.ok("File \"extensible_variant_test.res\", line 122, characters 17-24", false); + } + }); }); +let StrAlias = Str; + export { Str, N, Int$1 as Int, to_int, + Point, + StrAlias, + IntKey, + StringKey, + defaultOf, + Private, + privateName, + makeException, } /* Not a pure module */ diff --git a/tests/tests/src/extensible_variant_test.res b/tests/tests/src/extensible_variant_test.res index a17255efda8..72851d73c94 100644 --- a/tests/tests/src/extensible_variant_test.res +++ b/tests/tests/src/extensible_variant_test.res @@ -19,6 +19,55 @@ let to_int = (x: attr) => | _ => assert(false) } +// Inline records keep their field names, including @as renames. +type attr += Point({@as("x-coord") x: int, y: int}) + +// Rebinding gives an existing constructor a second name. +type attr += StrAlias = Str + +// Extensible types can be indexed like GADTs. +type key<_> = .. +type key<_> += IntKey: key +type key<_> += StringKey: key + +let defaultOf: + type a. key => option = + key => + switch key { + | IntKey => Some(0) + | StringKey => Some("") + | _ => None + } + +// Outside code can match a private extensible type but not extend it. +module Private: { + type t = private .. + type t += A + let b: t +} = { + type t = .. + type t += A | B + let b = B +} + +let privateName = (t: Private.t) => + switch t { + | Private.A => "A" + | _ => "other" + } + +// A local exception is a new constructor on every call. +let makeException = () => { + exception Local + let raise = () => throw(Local) + let isLocal = exn => + switch exn { + | Local => true + | _ => false + } + (raise, isLocal) +} + describe(__MODULE__, () => { test("test_int", () => { eq(__LOC__, 3, to_int(N.Int(3, 0))) @@ -31,4 +80,46 @@ describe(__MODULE__, () => { test("test_string", () => { eq(__LOC__, -1, to_int(Str("x"))) }) + + test("inline record", () => { + let point = Point({x: 1, y: 2}) + eq(__LOC__, 1, (Obj.magic(point): {"x-coord": int})["x-coord"]) + eq( + __LOC__, + 3, + switch point { + | Point({x, y}) => x + y + | _ => 0 + }, + ) + }) + + test("rebind", () => { + eq(__LOC__, -1, to_int(StrAlias("x"))) + eq(__LOC__, true, StrAlias("x") == Str("x")) + }) + + test("indexed extension", () => { + eq(__LOC__, Some(0), defaultOf(IntKey)) + eq(__LOC__, Some(""), defaultOf(StringKey)) + }) + + test("private extensible", () => { + eq(__LOC__, "A", privateName(Private.A)) + eq(__LOC__, "other", privateName(Private.b)) + }) + + test("local exceptions are generative", () => { + let (raise1, isLocal1) = makeException() + let (_, isLocal2) = makeException() + let caught = try raise1() catch { + | exn => Some(exn) + } + switch caught { + | Some(exn) => + eq(__LOC__, true, isLocal1(exn)) + eq(__LOC__, false, isLocal2(exn)) + | None => ok(__LOC__, false) + } + }) }) diff --git a/tests/tests/src/gadt_test.mjs b/tests/tests/src/gadt_test.mjs new file mode 100644 index 00000000000..bf4d137b0ab --- /dev/null +++ b/tests/tests/src/gadt_test.mjs @@ -0,0 +1,475 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; + +function $$eval(_expr) { + while (true) { + let expr = _expr; + switch (expr.TAG) { + case "Int" : + case "Bool" : + return expr._0; + case "Add" : + return $$eval(expr._0) + $$eval(expr._1) | 0; + case "Equal" : + return $$eval(expr._0) === $$eval(expr._1); + case "If" : + if ($$eval(expr._0)) { + _expr = expr._1; + continue; + } + _expr = expr._2; + continue; + case "Pair" : + return [ + $$eval(expr._0), + $$eval(expr._1) + ]; + case "First" : + return $$eval(expr._0)[0]; + } + }; +} + +function show(ty, value) { + if (typeof ty !== "object") { + if (ty === "TInt") { + return value.toString(); + } else { + return `"${value}"`; + } + } + switch (ty.TAG) { + case "TList" : + if (value === 0) { + return "[]"; + } + let ty$1 = ty._0; + return show(ty$1, value.hd) + "::" + show({ + TAG: "TList", + _0: ty$1 + }, value.tl); + case "TPair" : + return "(" + show(ty._0, value[0]) + ", " + show(ty._1, value[1]) + ")"; + case "TOption" : + if (value !== undefined) { + return "Some(" + show(ty._0, Primitive_option.valFromOption(value)) + ")"; + } else { + return "None"; + } + } +} + +function defaultOf(ty) { + if (typeof ty !== "object") { + if (ty === "TInt") { + return 0; + } else { + return ""; + } + } + switch (ty.TAG) { + case "TList" : + return /* [] */0; + case "TPair" : + throw { + RE_EXN_ID: "Invalid_argument", + _1: "no default pair", + Error: new Error() + }; + case "TOption" : + return; + } +} + +function intName(ty) { + return "int"; +} + +function cast(param, x) { + return x; +} + +function equalTy(a, b) { + if (typeof a !== "object") { + if (a === "TInt") { + if (typeof b !== "object" && b === "TInt") { + return "Refl"; + } else { + return; + } + } else if (typeof b !== "object" && b === "TString") { + return "Refl"; + } else { + return; + } + } + switch (a.TAG) { + case "TList" : + if (typeof b !== "object") { + return; + } + if (b.TAG !== "TList") { + return; + } + let match = equalTy(a._0, b._0); + if (match !== undefined) { + return "Refl"; + } else { + return; + } + case "TPair" : + if (typeof b !== "object") { + return; + } + if (b.TAG !== "TPair") { + return; + } + let match$1 = equalTy(a._0, b._0); + let match$2 = equalTy(a._1, b._1); + if (match$1 !== undefined && match$2 !== undefined) { + return "Refl"; + } else { + return; + } + case "TOption" : + if (typeof b !== "object") { + return; + } + if (b.TAG !== "TOption") { + return; + } + let match$3 = equalTy(a._0, b._0); + if (match$3 !== undefined) { + return "Refl"; + } else { + return; + } + } +} + +function fromDynamic(ty, param) { + let match = equalTy(param._0, ty); + if (match !== undefined) { + return Primitive_option.some(param._1); + } +} + +function showAll(items) { + return items.map(item => item.show(item.value)); +} + +function show$1(n) { + return n.toString(); +} + +let ShowInt = { + show: show$1 +}; + +function showBoxed(param) { + return param._0.show(param._1); +} + +function format(_fmt, _acc) { + while (true) { + let acc = _acc; + let fmt = _fmt; + if (typeof fmt !== "object") { + return acc; + } + switch (fmt.TAG) { + case "Text" : + _acc = acc + fmt._0; + _fmt = fmt._1; + continue; + case "IntArg" : + let rest = fmt._0; + return n => format(rest, acc + n.toString()); + case "StringArg" : + let rest$1 = fmt._0; + return s => format(rest$1, acc + s); + } + }; +} + +function sprintf(fmt) { + return format(fmt, ""); +} + +function fieldValue(field) { + if (typeof field !== "object") { + return; + } else if (field.TAG === "int") { + return field.v; + } else { + return field.s; + } +} + +function shapeValue(shape) { + if (shape.kind === "Circle") { + return shape.radius; + } else { + return shape.text; + } +} + +function primitiveValue(p) { + return p; +} + +function depth(n) { + if (n.TAG === "Flat") { + return 0; + } else { + return 1 + depth(n._0) | 0; + } +} + +Mocha.describe("Gadt_test", () => { + Mocha.test("evaluator", () => { + Test_utils.eq("File \"gadt_test.res\", line 203, characters 7-14", 10, $$eval({ + TAG: "If", + _0: { + TAG: "Equal", + _0: { + TAG: "Int", + _0: 1 + }, + _1: { + TAG: "Add", + _0: { + TAG: "Int", + _0: 0 + }, + _1: { + TAG: "Int", + _0: 1 + } + } + }, + _1: { + TAG: "Int", + _0: 10 + }, + _2: { + TAG: "Int", + _0: 20 + } + })); + Test_utils.eq("File \"gadt_test.res\", line 204, characters 7-14", true, $$eval({ + TAG: "First", + _0: { + TAG: "Pair", + _0: { + TAG: "Bool", + _0: true + }, + _1: { + TAG: "Int", + _0: 3 + } + } + })); + Test_utils.eq("File \"gadt_test.res\", line 205, characters 7-14", [ + 3, + false + ], $$eval({ + TAG: "Pair", + _0: { + TAG: "Add", + _0: { + TAG: "Int", + _0: 1 + }, + _1: { + TAG: "Int", + _0: 2 + } + }, + _1: { + TAG: "Equal", + _0: { + TAG: "Int", + _0: 1 + }, + _1: { + TAG: "Int", + _0: 2 + } + } + })); + }); + Mocha.test("type witnesses", () => { + Test_utils.eq("File \"gadt_test.res\", line 210, characters 6-13", `(1, "a")::(2, "b")::[]`, show({ + TAG: "TList", + _0: { + TAG: "TPair", + _0: "TInt", + _1: "TString" + } + }, {hd: [ + 1, + "a" + ], tl: {hd: [ + 2, + "b" + ], tl: /* [] */0}})); + Test_utils.eq("File \"gadt_test.res\", line 214, characters 7-14", "Some(None)", show({ + TAG: "TOption", + _0: { + TAG: "TOption", + _0: "TInt" + } + }, Primitive_option.some(undefined))); + Test_utils.eq("File \"gadt_test.res\", line 215, characters 7-14", 0, 0); + Test_utils.eq("File \"gadt_test.res\", line 216, characters 7-14", "", ""); + Test_utils.eq("File \"gadt_test.res\", line 217, characters 7-14", /* [] */0, /* [] */0); + Test_utils.eq("File \"gadt_test.res\", line 218, characters 7-14", undefined, undefined); + Test_utils.eq("File \"gadt_test.res\", line 219, characters 7-14", "int", "int"); + }); + Mocha.test("equality witness", () => { + Test_utils.eq("File \"gadt_test.res\", line 223, characters 7-14", 42, 42); + Test_utils.ok("File \"gadt_test.res\", line 224, characters 7-14", equalTy({ + TAG: "TList", + _0: "TInt" + }, { + TAG: "TList", + _0: "TInt" + }) !== undefined); + Test_utils.ok("File \"gadt_test.res\", line 225, characters 7-14", equalTy({ + TAG: "TPair", + _0: "TInt", + _1: "TString" + }, { + TAG: "TPair", + _0: "TInt", + _1: "TInt" + }) === undefined); + }); + Mocha.test("existentials", () => { + let values = [ + { + TAG: "Dynamic", + _0: "TInt", + _1: 1 + }, + { + TAG: "Dynamic", + _0: "TString", + _1: "x" + }, + { + TAG: "Dynamic", + _0: { + TAG: "TList", + _0: "TInt" + }, + _1: {hd: 1, tl: {hd: 2, tl: /* [] */0}} + } + ]; + Test_utils.eq("File \"gadt_test.res\", line 230, characters 7-14", [ + 1, + undefined, + undefined + ], values.map(v => fromDynamic("TInt", v))); + Test_utils.eq("File \"gadt_test.res\", line 231, characters 7-14", [ + undefined, + undefined, + {hd: 1, tl: {hd: 2, tl: /* [] */0}} + ], values.map(v => fromDynamic({ + TAG: "TList", + _0: "TInt" + }, v))); + Test_utils.eq("File \"gadt_test.res\", line 233, characters 6-13", [ + "1", + "s" + ], showAll([ + { + TAG: "Showable", + value: 1, + show: n => n.toString() + }, + { + TAG: "Showable", + value: "s", + show: s => s + } + ])); + Test_utils.eq("File \"gadt_test.res\", line 240, characters 7-14", "7", showBoxed({ + TAG: "Boxed", + _0: ShowInt, + _1: 7 + })); + }); + Mocha.test("typed printf", () => Test_utils.eq("File \"gadt_test.res\", line 244, characters 7-14", "x=1, y=b", format({ + TAG: "Text", + _0: "x=", + _1: { + TAG: "IntArg", + _0: { + TAG: "Text", + _0: ", y=", + _1: { + TAG: "StringArg", + _0: "End" + } + } + } + }, "")(1)("b"))); + Mocha.test("representation attributes", () => { + Test_utils.eq("File \"gadt_test.res\", line 248, characters 7-14", 3, 3); + Test_utils.eq("File \"gadt_test.res\", line 249, characters 7-14", "s", "s"); + Test_utils.eq("File \"gadt_test.res\", line 250, characters 7-14", { + TAG: "int", + v: 3 + }, { + TAG: "int", + v: 3 + }); + Test_utils.eq("File \"gadt_test.res\", line 251, characters 7-14", { + kind: "Circle", + radius: 1.5 + }, { + kind: "Circle", + radius: 1.5 + }); + Test_utils.eq("File \"gadt_test.res\", line 252, characters 7-14", "hi", "hi"); + Test_utils.eq("File \"gadt_test.res\", line 253, characters 7-14", 2, 2); + Test_utils.eq("File \"gadt_test.res\", line 254, characters 7-14", "u", "u"); + Test_utils.eq("File \"gadt_test.res\", line 255, characters 7-14", "u", "u"); + }); + Mocha.test("polymorphic recursion", () => Test_utils.eq("File \"gadt_test.res\", line 259, characters 7-14", 2, depth({ + TAG: "Nest", + _0: { + TAG: "Nest", + _0: { + TAG: "Flat", + _0: [[1]] + } + } + }))); +}); + +export { + $$eval, + show, + defaultOf, + intName, + cast, + equalTy, + fromDynamic, + showAll, + ShowInt, + showBoxed, + format, + sprintf, + fieldValue, + shapeValue, + primitiveValue, + depth, +} +/* Not a pure module */ diff --git a/tests/tests/src/gadt_test.res b/tests/tests/src/gadt_test.res new file mode 100644 index 00000000000..f431b313cb2 --- /dev/null +++ b/tests/tests/src/gadt_test.res @@ -0,0 +1,261 @@ +open Mocha +open Test_utils + +// A typed expression language: the index says what `eval` returns. +type rec expr<_> = + | Int(int): expr + | Bool(bool): expr + | Add(expr, expr): expr + | Equal(expr, expr): expr + | If(expr, expr<'a>, expr<'a>): expr<'a> + | Pair(expr<'a>, expr<'b>): expr<('a, 'b)> + | First(expr<('a, 'b)>): expr<'a> + +let rec eval: + type a. expr => a = + expr => + switch expr { + | Int(n) => n + | Bool(b) => b + | Add(a, b) => eval(a) + eval(b) + | Equal(a, b) => eval(a) == eval(b) + | If(cond, yes, no) => eval(cond) ? eval(yes) : eval(no) + | Pair(a, b) => (eval(a), eval(b)) + | First(pair) => + let (a, _) = eval(pair) + a + } + +// Type witnesses: one function, a different result type per witness. +type rec ty<_> = + | TInt: ty + | TString: ty + | TList(ty<'a>): ty> + | TPair(ty<'a>, ty<'b>): ty<('a, 'b)> + | TOption(ty<'a>): ty> + +let rec show: + type a. (ty, a) => string = + (ty, value) => + switch (ty, value) { + | (TInt, n) => Int.toString(n) + | (TString, s) => `"${s}"` + | (TList(_), list{}) => "[]" + | (TList(ty), list{x, ...rest}) => show(ty, x) ++ "::" ++ show(TList(ty), rest) + | (TPair(a, b), (x, y)) => "(" ++ show(a, x) ++ ", " ++ show(b, y) ++ ")" + | (TOption(_), None) => "None" + | (TOption(ty), Some(x)) => "Some(" ++ show(ty, x) ++ ")" + } + +let defaultOf: + type a. ty => a = + ty => + switch ty { + | TInt => 0 + | TString => "" + | TList(_) => list{} + | TPair(_, _) => throw(Invalid_argument("no default pair")) + | TOption(_) => None + } + +// A match on a refined index needs no case for impossible constructors. +let intName = (ty: ty) => + switch ty { + | TInt => "int" + } + +// Equality witness and a runtime type equality check. +type rec equal<_, _> = Refl: equal<'a, 'a> + +let cast = (type a b, Refl: equal, x: a): b => x + +let rec equalTy: + type a b. (ty, ty) => option> = + (a, b) => + switch (a, b) { + | (TInt, TInt) => Some(Refl) + | (TString, TString) => Some(Refl) + | (TList(a), TList(b)) => + switch equalTy(a, b) { + | Some(Refl) => Some(Refl) + | None => None + } + | (TOption(a), TOption(b)) => + switch equalTy(a, b) { + | Some(Refl) => Some(Refl) + | None => None + } + | (TPair(a1, b1), TPair(a2, b2)) => + switch (equalTy(a1, a2), equalTy(b1, b2)) { + | (Some(Refl), Some(Refl)) => Some(Refl) + | _ => None + } + | _ => None + } + +// Existential types: the payload type is hidden from the outside. +type rec dynamic = Dynamic(ty<'a>, 'a): dynamic + +let fromDynamic = (type a, ty: ty, Dynamic(ty2, value)): option => + switch equalTy(ty2, ty) { + | Some(Refl) => Some(value) + | None => None + } + +type rec showable = Showable({value: 'a, show: 'a => string}): showable + +let showAll = items => + items->Array.map(item => + switch item { + | Showable({value, show}) => show(value) + } + ) + +// Existential packing a first-class module. +module type Show = { + type t + let show: t => string +} + +type rec boxed = Boxed(module(Show with type t = 'a), 'a): boxed + +module ShowInt = { + type t = int + let show = n => Int.toString(n) +} + +let showBoxed = (Boxed(m, value)) => { + module M = unpack(m) + M.show(value) +} + +// The index can drive the shape of a function: a typed printf. +type rec format<_> = + | End: format + | Text(string, format<'a>): format<'a> + | IntArg(format<'a>): format 'a> + | StringArg(format<'a>): format 'a> + +let rec format: + type a. (format, string) => a = + (fmt, acc) => + switch fmt { + | End => acc + | Text(s, rest) => format(rest, acc ++ s) + | IntArg(rest) => n => format(rest, acc ++ Int.toString(n)) + | StringArg(rest) => s => format(rest, acc ++ s) + } + +let sprintf = fmt => format(fmt, "") + +// Runtime representation attributes work on GADT constructors. +type rec field<_> = + | @as("int") IntField({@as("v") n: int}): field + | StringField({s: string}): field + | Empty: field + +let fieldValue: + type a. field => a = + field => + switch field { + | IntField({n}) => n + | StringField({s}) => s + | Empty => () + } + +@tag("kind") +type rec shape<_> = + | Circle({radius: float}): shape + | Label({text: string}): shape + +let shapeValue: + type a. shape => a = + shape => + switch shape { + | Circle({radius}) => radius + | Label({text}) => text + } + +@unboxed +type rec primitive<_> = + | Number(float): primitive + | Str(string): primitive + +let primitiveValue: + type a. primitive => a = + p => + switch p { + | Number(f) => f + | Str(s) => s + } + +// Polymorphic recursion on a nested (non-regular) type. +type rec nested<'a> = Flat('a) | Nest(nested>) + +let rec depth: 'a. nested<'a> => int = n => + switch n { + | Flat(_) => 0 + | Nest(n) => 1 + depth(n) + } + +describe(__MODULE__, () => { + test("evaluator", () => { + eq(__LOC__, 10, eval(If(Equal(Int(1), Add(Int(0), Int(1))), Int(10), Int(20)))) + eq(__LOC__, true, eval(First(Pair(Bool(true), Int(3))))) + eq(__LOC__, (3, false), eval(Pair(Add(Int(1), Int(2)), Equal(Int(1), Int(2))))) + }) + + test("type witnesses", () => { + eq( + __LOC__, + `(1, "a")::(2, "b")::[]`, + show(TList(TPair(TInt, TString)), list{(1, "a"), (2, "b")}), + ) + eq(__LOC__, "Some(None)", show(TOption(TOption(TInt)), Some(None))) + eq(__LOC__, 0, defaultOf(TInt)) + eq(__LOC__, "", defaultOf(TString)) + eq(__LOC__, list{}, defaultOf(TList(TInt))) + eq(__LOC__, None, defaultOf(TOption(TString))) + eq(__LOC__, "int", intName(TInt)) + }) + + test("equality witness", () => { + eq(__LOC__, 42, cast(Refl, 42)) + ok(__LOC__, equalTy(TList(TInt), TList(TInt)) != None) + ok(__LOC__, equalTy(TPair(TInt, TString), TPair(TInt, TInt)) == None) + }) + + test("existentials", () => { + let values = [Dynamic(TInt, 1), Dynamic(TString, "x"), Dynamic(TList(TInt), list{1, 2})] + eq(__LOC__, [Some(1), None, None], values->Array.map(v => fromDynamic(TInt, v))) + eq(__LOC__, [None, None, Some(list{1, 2})], values->Array.map(v => fromDynamic(TList(TInt), v))) + eq( + __LOC__, + ["1", "s"], + showAll([ + Showable({value: 1, show: n => Int.toString(n)}), + Showable({value: "s", show: s => s}), + ]), + ) + eq(__LOC__, "7", showBoxed(Boxed(module(ShowInt), 7))) + }) + + test("typed printf", () => { + eq(__LOC__, "x=1, y=b", sprintf(Text("x=", IntArg(Text(", y=", StringArg(End)))))(1)("b")) + }) + + test("representation attributes", () => { + eq(__LOC__, 3, fieldValue(IntField({n: 3}))) + eq(__LOC__, "s", fieldValue(StringField({s: "s"}))) + eq(__LOC__, {"TAG": "int", "v": 3}, Obj.magic(IntField({n: 3}))) + eq(__LOC__, {"kind": "Circle", "radius": 1.5}, Obj.magic(Circle({radius: 1.5}))) + eq(__LOC__, "hi", shapeValue(Label({text: "hi"}))) + eq(__LOC__, 2., primitiveValue(Number(2.))) + eq(__LOC__, "u", primitiveValue(Str("u"))) + eq(__LOC__, "u", Obj.magic(Str("u"))) + }) + + test("polymorphic recursion", () => { + eq(__LOC__, 2, depth(Nest(Nest(Flat([[1]]))))) + }) +})