From 345673c9533123c4715d26e41ad18f858710045b Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 28 Apr 2014 21:08:53 -0700 Subject: [PATCH] Simplify failure case in tc-apply. --- .../typed-racket/typecheck/tc-apply.rkt | 35 ++++++++----------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt index aceb8b7b22..ddd72fb4f8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt @@ -42,6 +42,18 @@ (values tail-ty tail-bound)] [t (values #f #f)])) + (define (failure) + (match f-ty + [(tc-result1: + (and t (or (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)) + (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))) + (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))) + (domain-mismatches f args t doms rests drests rngs arg-tres full-tail-ty #f + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to function in `apply':\n" + dom)))])) + (match f-ty ;; apply of simple function [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) @@ -62,11 +74,7 @@ ;; the function has no rest argument [else (-val '())]))) (do-ret range))) - (domain-mismatches f args t doms rests drests rngs arg-tres full-tail-ty #f - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to function in `apply':\n" - dom))))] + (failure))] ;; apply of simple polymorphic function [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) (or @@ -99,13 +107,7 @@ range)) => finish] [else #f])) - (match f-ty - [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) - (domain-mismatches f args t doms rests drests rngs arg-tres (or tail-ty full-tail-ty) tail-bound - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to polymorphic function in `apply':\n" - dom)))]))] + (failure))] [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) (or @@ -158,14 +160,7 @@ [_ #f])) => finish] [else #f])) - ;; Nothing matched - (match f-ty - [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) - (domain-mismatches f args t doms rests drests rngs arg-tres (or tail-ty full-tail-ty) tail-bound - #:msg-thunk (lambda (dom) - (string-append - "Bad arguments to polymorphic function in `apply':\n" - dom)))]))] + (failure))] [(tc-result1: (or (Function: '()) (Poly: _ (Function: '())) (PolyDots: _ (Function: '())))) (tc-error/expr "Function has no cases")] [(tc-result1: f-ty)