suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improved TR's error messages when all domains but one have been eliminated.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-10-07 17:19:27 -04:00
parent 65ad6aee20
commit db0046101c
5 changed files with 186 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-scheme/fail/dead-substruct.rkt
View File

@ -1,5 +1,5 @@
#; #;
(exn-pred 1) (exn-pred 2)
#lang typed/scheme #lang typed/scheme
(define-struct: parent ((x : Integer))) (define-struct: parent ((x : Integer)))

196
collects/typed-scheme/typecheck/tc-app-helper.rkt
View File

@ -1,11 +1,54 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.rkt" racket/match unstable/list (require "../utils/utils.rkt" racket/match unstable/list unstable/sequence
(only-in srfi/1 unzip4) (only-in racket/list make-list) (only-in srfi/1 unzip4) (only-in racket/list make-list)
(utils tc-utils) (rep type-rep) (types utils union abbrev subtype)) (prefix-in c: racket/contract)
"check-below.rkt" "tc-subst.rkt"
(utils tc-utils)
(rep type-rep object-rep)
(types utils union abbrev subtype))
(provide (all-defined-out)) (provide (all-defined-out))
;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?)
(match* (ftype0 argtys)
;; we check that all kw args are optional
[((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...)))
(list (tc-result1: t-a phi-a o-a) ...))
(when check?
(cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
[(and rest (< (length t-a) (length dom)))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))]
[a (in-list (syntax->list args-stx))]
[arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* ([dom-count (length dom)]
[arg-count (+ dom-count (if rest 1 0) (length kws))])
(let-values
([(o-a t-a) (for/lists (os ts)
([nm (in-range arg-count)]
[oa (in-sequence-forever (in-list o-a) (make-Empty))]
[ta (in-sequence-forever (in-list t-a) (Un))])
(values (if (>= nm dom-count) (make-Empty) oa)
ta))])
(define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r)
([r (in-list results)])
(open-Result r o-a t-a)))
(ret t-r f-r o-r)))]
[((arr: _ _ _ drest '()) _)
(int-err "funapp with drest args ~a ~a NYI" drest argtys)]
[((arr: _ _ _ _ kws) _)
(int-err "funapp with keyword args ~a NYI" kws)]))
(define (make-printable t) (define (make-printable t)
(match t (match t
[(tc-result1: t) t] [(tc-result1: t) t]
@ -21,8 +64,17 @@
(format "~a~a *~a" doms-string rst rng-string)] (format "~a~a *~a" doms-string rst rng-string)]
[else (string-append (stringify (map make-printable dom)) rng-string)]))) [else (string-append (stringify (map make-printable dom)) rng-string)])))
(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound ;; Generates error messages when operand types don't match operator domains.
#:expected [expected #f]) (d/c (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound
#:expected [expected #f] #:return [return (make-Union null)]
#:msg-thunk [msg-thunk (lambda (dom) dom)])
((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c))
(c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?))))
(c:listof (c:or/c Values? ValuesDots?)) (c:listof tc-results?) (c:or/c #f Type/c) c:any/c)
(#:expected (c:or/c #f tc-results?) #:return tc-results?
#:msg-thunk (c:-> string? string?))
. c:->* . tc-results?)
(define arguments-str (define arguments-str
(stringify-domain arg-tys (stringify-domain arg-tys
(if (not tail-bound) tail-ty #f) (if (not tail-bound) tail-ty #f)
@ -31,52 +83,71 @@
[(null? doms) [(null? doms)
(int-err "How could doms be null: ~a ~a" ty)] (int-err "How could doms be null: ~a ~a" ty)]
[(and (= 1 (length doms)) (not (car rests)) (not (car drests)) (not tail-ty) (not tail-bound)) [(and (= 1 (length doms)) (not (car rests)) (not (car drests)) (not tail-ty) (not tail-bound))
(apply string-append (tc-error/expr
(if (not (= (length (car doms)) (length arg-tys))) #:return return
(format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys)) (msg-thunk
"") (apply string-append
(append (if (not (= (length (car doms)) (length arg-tys)))
(for/list ([dom-t (in-list (extend arg-tys (car doms) #f))] (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys))
[arg-t (in-list (extend (car doms) arg-tys #f))] "")
[i (in-naturals 1)]) (append
(let ([dom-t (or dom-t "-none-")] (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))]
[arg-t (or arg-t "-none-")]) [arg-t (in-list (extend (car doms) arg-tys #f))]
(format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t)))) [i (in-naturals 1)])
(list (let ([dom-t (or dom-t "-none-")]
(if expected [arg-t (or arg-t "-none-")])
(format "\nResult type: ~a\nExpected result: ~a\n" (format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t))))
(car rngs) (make-printable expected)) (list
""))))] (if expected
(format "\nResult type: ~a\nExpected result: ~a\n"
(car rngs) (make-printable expected))
""))))))]
[(= 1 (length doms)) [(= 1 (length doms))
(string-append (tc-error/expr
"Domain: " #:return return
(stringify-domain (car doms) (car rests) (car drests)) (msg-thunk
"\nArguments: " (string-append
arguments-str "Domain: "
"\n" (stringify-domain (car doms) (car rests) (car drests))
(if expected "\nArguments: "
(format "Result type: ~a\nExpected result: ~a\n" arguments-str
(car rngs) (make-printable expected)) "\n"
""))] (if expected
(format "Result type: ~a\nExpected result: ~a\n"
(car rngs) (make-printable expected))
""))))]
[else [else
(let ([label (if expected "Types: " "Domains: ")] (let ([label (if expected "Types: " "Domains: ")]
[nl+spc (if expected "\n " "\n ")]) [nl+spc (if expected "\n " "\n ")])
;; we restrict the domains shown in the error messages to those that ;; we restrict the domains shown in the error messages to those that
;; are useful ;; are useful
(let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)]) (let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)])
(let ([pdoms (map make-printable pdoms)]) (if (= (length pdoms) 1)
(string-append ;; if we narrowed down the possible cases to a single one, have
label ;; tc/funapp1 generate a better error message
(stringify (if expected (begin (tc/funapp1 f-stx args-stx
(map stringify-domain pdoms rests drests rngs) (make-arr (car pdoms) (car rngs)
(map stringify-domain pdoms rests drests)) (car rests) (car drests) null)
nl+spc) arg-tys expected)
"\nArguments: " return)
arguments-str ;; if not, print the message as usual
"\n" (let* ([pdoms (map make-printable pdoms)]
(if expected [err-doms
(format "Expected result: ~a\n" (make-printable expected)) (string-append
"")))))])) label
(stringify (if expected
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str
"\n"
(if expected
(format "Expected result: ~a\n" (make-printable expected))
""))])
(tc-error/expr
#:return return
(msg-thunk err-doms))))))])) ; generate message
;; to avoid long and confusing error messages, in the case of functions with ;; to avoid long and confusing error messages, in the case of functions with
@ -177,7 +248,8 @@
(let ([fun-tys-ret-any (let ([fun-tys-ret-any
(map (match-lambda (map (match-lambda
[(Function: (list (arr: dom _ rest drest _))) [(Function: (list (arr: dom _ rest drest _)))
(make-Function (list (make-arr dom Univ rest drest null)))]) (make-Function (list (make-arr dom (-values (list Univ))
rest drest null)))])
candidates)]) candidates)])
(let loop ([cases fun-tys-ret-any] (let loop ([cases fun-tys-ret-any]
[parts parts-acc] [parts parts-acc]
@ -200,7 +272,7 @@
orig orig
(reverse parts-acc))))))))))) (reverse parts-acc)))))))))))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) (define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f])
(match t (match t
[(or (Poly-names: [(or (Poly-names:
msg-vars msg-vars
@ -218,13 +290,16 @@
"Could not infer types for applying polymorphic " "Could not infer types for applying polymorphic "
fcn-string fcn-string
"\n")) "\n"))
(tc-error/expr #:return (ret (Un)) (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests
(string-append msg-rngs argtypes #f #f #:expected expected
"Polymorphic " fcn-string " could not be applied to arguments:\n" #:return (ret (Un))
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) #:msg-thunk (lambda (dom)
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) (string-append
(string-append "Type Variables: " (stringify msg-vars) "\n") "Polymorphic " fcn-string " could not be applied to arguments:\n"
"")))))] dom
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))))
(let ([fcn-string (if name (let ([fcn-string (if name
@ -237,10 +312,13 @@
"Could not infer types for applying polymorphic " "Could not infer types for applying polymorphic "
fcn-string fcn-string
"\n")) "\n"))
(tc-error/expr #:return (ret (Un)) (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests
(string-append msg-rngs argtypes #f #f #:expected expected
"Polymorphic " fcn-string " could not be applied to arguments:\n" #:return (ret (Un))
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) #:msg-thunk (lambda (dom)
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) (string-append
(string-append "Type Variables: " (stringify msg-vars) "\n") "Polymorphic " fcn-string " could not be applied to arguments:\n"
"")))))])) dom
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]))

20
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -137,15 +137,19 @@
(match a (match a
[(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))])
(if (null? new-arities) (if (null? new-arities)
(tc-error/expr (domain-mismatches
(car (syntax-e form)) (cdr (syntax-e form))
arities doms rests drests rngs
(map tc-expr (syntax->list pos-args))
#f #f #:expected expected
#:return (or expected (ret (Un))) #:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n" #:msg-thunk
(domain-mismatches arities doms rests drests rngs (lambda (dom)
(map tc-expr (syntax->list pos-args)) (string-append "No function domains matched in function application:\n"
#f #f #:expected expected))) dom)))
(tc/funapp (car (syntax-e form)) kw-args (tc/funapp (car (syntax-e form)) kw-args
(ret (make-Function new-arities)) (ret (make-Function new-arities))
(map tc-expr (syntax->list pos-args)) expected)))])) (map tc-expr (syntax->list pos-args)) expected)))]))
(define (type->list t) (define (type->list t)
(match t (match t

47
collects/typed-scheme/typecheck/tc-apply.rkt
View File

@ -40,21 +40,24 @@
(match f-ty (match f-ty
;; apply of simple function ;; apply of simple function
[(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))) [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))))
;; special case for (case-lambda) ;; special case for (case-lambda)
(when (null? doms) (when (null? doms)
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply")) "empty case-lambda given as argument to apply"))
(match-let ([arg-tys (map tc-expr/t fixed-args)] (match-let* ([arg-tres (map tc-expr fixed-args)]
[(tc-result1: tail-ty) (single-value tail)]) [arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tc-result1: tail-ty) (single-value tail)])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond (cond
;; we've run out of cases to try, so error out ;; we've run out of cases to try, so error out
[(null? doms*) [(null? doms*)
(tc-error/expr #:return (ret (Un)) (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f
(string-append #:return (ret (Un))
"Bad arguments to function in apply:\n" #:msg-thunk (lambda (dom)
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty #f)))] (string-append
"Bad arguments to function in apply:\n"
dom)))]
;; this case of the function type has a rest argument ;; this case of the function type has a rest argument
[(and (car rests*) [(and (car rests*)
;; check that the tail expression is a subtype of the rest argument ;; check that the tail expression is a subtype of the rest argument
@ -76,7 +79,8 @@
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
;; apply of simple polymorphic function ;; apply of simple polymorphic function
[(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)] (let*-values ([(arg-tres) (map tc-expr fixed-args)]
[(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tail-ty tail-bound) (match (tc-expr/t tail) [(tail-ty tail-bound) (match (tc-expr/t tail)
[(ListDots: tail-ty tail-bound) [(ListDots: tail-ty tail-bound)
(values tail-ty tail-bound)] (values tail-ty tail-bound)]
@ -84,11 +88,13 @@
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*) (cond [(null? doms*)
(match f-ty (match f-ty
[(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))
(tc-error/expr #:return (ret (Un)) (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound
(string-append #:return (ret (Un))
"Bad arguments to polymorphic function in apply:\n" #:msg-thunk (lambda (dom)
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] (string-append
"Bad arguments to polymorphic function in apply:\n"
dom)))])]
;; the actual work, when we have a * function and a list final argument ;; the actual work, when we have a * function and a list final argument
[(and (car rests*) [(and (car rests*)
(not tail-bound) (not tail-bound)
@ -129,7 +135,8 @@
"Function has no cases")] "Function has no cases")]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)] (let*-values ([(arg-tres) (map tc-expr fixed-args)]
[(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tail-ty tail-bound) (match (tc-expr/t tail) [(tail-ty tail-bound) (match (tc-expr/t tail)
[(ListDots: tail-ty tail-bound) [(ListDots: tail-ty tail-bound)
(values tail-ty tail-bound)] (values tail-ty tail-bound)]
@ -138,11 +145,13 @@
(define (finish substitution) (do-ret (subst-all substitution (car rngs*)))) (define (finish substitution) (do-ret (subst-all substitution (car rngs*))))
(cond [(null? doms*) (cond [(null? doms*)
(match f-ty (match f-ty
[(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))
(tc-error/expr #:return (ret (Un)) (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound
(string-append #:return (ret (Un))
"Bad arguments to polymorphic function in apply:\n" #:msg-thunk (lambda (dom)
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] (string-append
"Bad arguments to polymorphic function in apply:\n"
dom)))])]
;; the actual work, when we have a * function and a list final argument ;; the actual work, when we have a * function and a list final argument
[(and (car rests*) [(and (car rests*)
(not tail-bound) (not tail-bound)

54
collects/typed-scheme/typecheck/tc-funapp.rkt
View File

@ -3,9 +3,8 @@
(require (rename-in "../utils/utils.rkt" [infer r:infer]) (require (rename-in "../utils/utils.rkt" [infer r:infer])
"signatures.rkt" "tc-metafunctions.rkt" "signatures.rkt" "tc-metafunctions.rkt"
"tc-app-helper.rkt" "find-annotation.rkt" "tc-app-helper.rkt" "find-annotation.rkt"
"tc-subst.rkt" "check-below.rkt"
(prefix-in c: racket/contract) (prefix-in c: racket/contract)
syntax/parse racket/match racket/list unstable/sequence syntax/parse racket/match racket/list
;; fixme - don't need to be bound in this phase - only to make syntax/parse happy ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
racket/bool racket/unsafe/ops racket/bool racket/unsafe/ops
(only-in racket/private/class-internal make-object do-make-object) (only-in racket/private/class-internal make-object do-make-object)
@ -16,7 +15,7 @@
(types utils abbrev union subtype resolve convenience type-table substitute) (types utils abbrev union subtype resolve convenience type-table substitute)
(utils tc-utils) (utils tc-utils)
(except-in (env type-env-structs tvar-env index-env) extend) (except-in (env type-env-structs tvar-env index-env) extend)
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep rep-utils)
(r:infer infer) (r:infer infer)
'#%paramz '#%paramz
(for-template (for-template
@ -37,7 +36,7 @@
(let ([substitution (infer vars ... a)]) (let ([substitution (infer vars ... a)])
(and substitution (and substitution
(tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f)))) (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f))))
(poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) (poly-fail f-stx args-stx t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
(d/c (tc/funapp f-stx args-stx ftype0 argtys expected) (d/c (tc/funapp f-stx args-stx ftype0 argtys expected)
(syntax? syntax? tc-results? (c:listof tc-results?) (c:or/c #f tc-results?) . c:-> . tc-results?) (syntax? syntax? tc-results? (c:listof tc-results?) (c:or/c #f tc-results?) . c:-> . tc-results?)
@ -55,10 +54,11 @@
;; we call the separate function so that we get the appropriate filters/objects ;; we call the separate function so that we get the appropriate filters/objects
(tc/funapp1 f-stx args-stx a argtys expected #:check #f)) (tc/funapp1 f-stx args-stx a argtys expected #:check #f))
;; if nothing matched, error ;; if nothing matched, error
(tc-error/expr (domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f
#:return (or expected (ret (Un))) #:expected expected #:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n" #:msg-thunk (lambda (dom)
(domain-mismatches t doms rests drests rngs argtys-t #f #f #:expected expected))))] (string-append "No function domains matched in function application:\n"
dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args ;; any kind of dotted polymorphic function without mandatory keyword args
[((tc-result1: (and t (PolyDots: [((tc-result1: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var)) (and vars (list fixed-vars ... dotted-var))
@ -127,41 +127,3 @@
[((tc-result1: f-ty) _) [((tc-result1: f-ty) _)
(tc-error/expr #:return (ret (Un)) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" f-ty)])) "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))
;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?)
(match* (ftype0 argtys)
;; we check that all kw args are optional
[((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...)))
(list (tc-result1: t-a phi-a o-a) ...))
(when check?
(cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
[(and rest (< (length t-a) (length dom)))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))]
[a (in-list (syntax->list args-stx))]
[arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* ([dom-count (length dom)]
[arg-count (+ dom-count (if rest 1 0) (length kws))])
(let-values
([(o-a t-a) (for/lists (os ts)
([nm (in-range arg-count)]
[oa (in-sequence-forever (in-list o-a) (make-Empty))]
[ta (in-sequence-forever (in-list t-a) (Un))])
(values (if (>= nm dom-count) (make-Empty) oa)
ta))])
(define-values (t-r f-r o-r)
(for/lists (t-r f-r o-r)
([r (in-list results)])
(open-Result r o-a t-a)))
(ret t-r f-r o-r)))]
[((arr: _ _ _ drest '()) _)
(int-err "funapp with drest args ~a ~a NYI" drest argtys)]
[((arr: _ _ _ _ kws) _)
(int-err "funapp with keyword args ~a NYI" kws)]))