diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/generalize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/generalize.rkt index eefa91d05f..ad675fa2fb 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/generalize.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/generalize.rkt @@ -29,19 +29,20 @@ [(? (lambda (t) (subtype t -SingleFlonumComplex))) -SingleFlonumComplex] [(? (lambda (t) (subtype t -Number))) -Number] [(? (lambda (t) (subtype t -ExtFlonum))) -ExtFlonum] - [(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*] + [(Listof: _) t*] [(Pair: t1 (Value: '())) (-lst t1)] [(MPair: t1 (Value: '())) (-mlst t1)] [(or (Pair: t1 t2) (MPair: t1 t2)) (let ([t-new (loop t2)]) - (if (type-equal? ((match t* - [(Pair: _ _) -lst] - [(MPair: _ _) -mlst]) - t1) - t-new) - t-new + (define -lst-type + ((match t* + [(Pair: _ _) -lst] + [(MPair: _ _) -mlst]) + t1)) + (if (type-compare? -lst-type t-new) + -lst-type (exit t)))] [(ListDots: t bound) (-lst (substitute Univ bound t))] [(? (lambda (t) (subtype t -Symbol))) -Symbol] [(Value: #t) -Boolean] - [_ (exit t)])))) + [_ t*])))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 6135a5583f..c28d87d77a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -40,4 +40,5 @@ "init-env-tests.rkt" "filter-tests.rkt" "metafunction-tests.rkt" + "generalize-tests.rkt" "rep-tests.rkt") diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/generalize-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/generalize-tests.rkt new file mode 100644 index 0000000000..9eb2a3cdac --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/generalize-tests.rkt @@ -0,0 +1,34 @@ +#lang racket/base + +(require "test-utils.rkt" + racket/format + rackunit + (rep rep-utils) + (types generalize abbrev union) + (for-syntax racket/base syntax/parse)) + +(provide tests) +(gen-test-main) + +(define-syntax check-generalize + (syntax-parser + [(_ t*:expr exp*:expr) + #'(test-case (~a `(t* => exp*)) + (define actual (generalize t*)) + (define expected exp*) + (with-check-info (['actual actual] + ['expected expected]) + (unless (type-equal? actual expected) + (fail-check "Didn't generalize to expected type."))))])) + + +(define tests + (test-suite "Generalize Tests" + (check-generalize -Null (-lst Univ)) + (check-generalize + (-pair -Symbol (-lst -Symbol)) + (-lst -Symbol)) + (check-generalize + (-pair -Symbol (Un -Null (-pair -Symbol (-lst -Symbol)))) + (-lst -Symbol)) + ))