diff --git a/collects/tests/typed-racket/succeed/pr12644.rkt b/collects/tests/typed-racket/succeed/pr12644.rkt new file mode 100644 index 00000000..9c4fad47 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr12644.rkt @@ -0,0 +1,23 @@ +#lang typed/racket + +(define-type inf (Rec inf (Any -> inf))) +(: f inf) +(define (f x) f) + +(: g (All (x) (x -> x))) +(define (g x) x) + +(: v (Listof (U inf Byte))) +(define v + (list + (with-handlers ((void values)) 2) + (with-handlers ((void add1)) 3) + (with-handlers ((void f)) 4) + (with-handlers ((void g)) 5))) + + +(list + (with-handlers ((void values)) 6) + (with-handlers ((void add1)) 7) + (with-handlers ((void f)) 8) + (with-handlers ((void g)) 9)) diff --git a/collects/typed-racket/typecheck/check-subforms-unit.rkt b/collects/typed-racket/typecheck/check-subforms-unit.rkt index 1b954b87..5b9221ea 100644 --- a/collects/typed-racket/typecheck/check-subforms-unit.rkt +++ b/collects/typed-racket/typecheck/check-subforms-unit.rkt @@ -6,7 +6,7 @@ racket/match "signatures.rkt" "tc-metafunctions.rkt" "tc-funapp.rkt" "tc-subst.rkt" - (types utils abbrev union subtype) + (types utils abbrev union subtype resolve) (utils tc-utils) (rep type-rep)) @@ -42,10 +42,15 @@ ;; The result of applying the function to a single argument of type (Un) ;; FIXME: (Un) is the wrong type, see above fixme (define (get-result-ty t) - (match t - [(tc-result1: (Function: _)) - (tc/funapp #'here #'(here) t (list (ret (Un))) #f)] - [_ (int-err "Unsupported function type in get-result-ty: \n~a" t)])) + (let loop ((t t)) + (match t + [(Function: _) + (tc/funapp #'here #'(here) (ret t) (list (ret (Un))) #f)] + [(? needs-resolving? t) + (loop (resolve t))] + [(or (Poly: ns _) (PolyDots: (list ns ... _) _)) + (loop (instantiate-poly t (map (λ (n) Univ) ns)))] + [_ (int-err "Unsupported function type in get-result-ty: \n~a" t)]))) (let loop ([form form]) (parameterize ([current-orig-stx form]) (syntax-parse form @@ -59,10 +64,8 @@ #:when (syntax-property form 'typechecker:exn-handler) (let ([t (single-value form)]) (match t - [(tc-result1: (Function: _)) - (set! handler-tys (cons (get-result-ty t) handler-tys))] - [(tc-results: t) - (tc-error "Exception handler must be a function, got \n~a" t)]))] + [(tc-result1: t) + (set! handler-tys (cons (get-result-ty t) handler-tys))]))] [stx ;; this is the body of the with-handlers #:when (syntax-property form 'typechecker:exn-body)