Improved TR's error messages when all domains but one have been eliminated.
This commit is contained in:
Vincent St-Amour
parent
65ad6aee20
commit
db0046101c
|
|
@ -1,5 +1,5 @@
|
|||
#;
|
||||
(exn-pred 1)
|
||||
(exn-pred 2)
|
||||
#lang typed/scheme
|
||||
|
||||
(define-struct: parent ((x : Integer)))
|
||||
|
|
|
|||
|
|
@ -1,11 +1,54 @@
|
|||
#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)
|
||||
(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))
|
||||
|
||||
|
||||
;; 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)
|
||||
(match t
|
||||
[(tc-result1: t) t]
|
||||
|
|
@ -21,8 +64,17 @@
|
|||
(format "~a~a *~a" doms-string rst 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
|
||||
#:expected [expected #f])
|
||||
;; Generates error messages when operand types don't match operator domains.
|
||||
(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
|
||||
(stringify-domain arg-tys
|
||||
(if (not tail-bound) tail-ty #f)
|
||||
|
|
@ -31,52 +83,71 @@
|
|||
[(null? doms)
|
||||
(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))
|
||||
(apply string-append
|
||||
(if (not (= (length (car doms)) (length arg-tys)))
|
||||
(format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys))
|
||||
"")
|
||||
(append
|
||||
(for/list ([dom-t (in-list (extend arg-tys (car doms) #f))]
|
||||
[arg-t (in-list (extend (car doms) arg-tys #f))]
|
||||
[i (in-naturals 1)])
|
||||
(let ([dom-t (or dom-t "-none-")]
|
||||
[arg-t (or arg-t "-none-")])
|
||||
(format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t))))
|
||||
(list
|
||||
(if expected
|
||||
(format "\nResult type: ~a\nExpected result: ~a\n"
|
||||
(car rngs) (make-printable expected))
|
||||
""))))]
|
||||
(tc-error/expr
|
||||
#:return return
|
||||
(msg-thunk
|
||||
(apply string-append
|
||||
(if (not (= (length (car doms)) (length arg-tys)))
|
||||
(format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys))
|
||||
"")
|
||||
(append
|
||||
(for/list ([dom-t (in-list (extend arg-tys (car doms) #f))]
|
||||
[arg-t (in-list (extend (car doms) arg-tys #f))]
|
||||
[i (in-naturals 1)])
|
||||
(let ([dom-t (or dom-t "-none-")]
|
||||
[arg-t (or arg-t "-none-")])
|
||||
(format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t))))
|
||||
(list
|
||||
(if expected
|
||||
(format "\nResult type: ~a\nExpected result: ~a\n"
|
||||
(car rngs) (make-printable expected))
|
||||
""))))))]
|
||||
[(= 1 (length doms))
|
||||
(string-append
|
||||
"Domain: "
|
||||
(stringify-domain (car doms) (car rests) (car drests))
|
||||
"\nArguments: "
|
||||
arguments-str
|
||||
"\n"
|
||||
(if expected
|
||||
(format "Result type: ~a\nExpected result: ~a\n"
|
||||
(car rngs) (make-printable expected))
|
||||
""))]
|
||||
(tc-error/expr
|
||||
#:return return
|
||||
(msg-thunk
|
||||
(string-append
|
||||
"Domain: "
|
||||
(stringify-domain (car doms) (car rests) (car drests))
|
||||
"\nArguments: "
|
||||
arguments-str
|
||||
"\n"
|
||||
(if expected
|
||||
(format "Result type: ~a\nExpected result: ~a\n"
|
||||
(car rngs) (make-printable expected))
|
||||
""))))]
|
||||
[else
|
||||
(let ([label (if expected "Types: " "Domains: ")]
|
||||
[nl+spc (if expected "\n " "\n ")])
|
||||
;; we restrict the domains shown in the error messages to those that
|
||||
;; are useful
|
||||
(let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)])
|
||||
(let ([pdoms (map make-printable pdoms)])
|
||||
(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))
|
||||
"")))))]))
|
||||
(if (= (length pdoms) 1)
|
||||
;; if we narrowed down the possible cases to a single one, have
|
||||
;; tc/funapp1 generate a better error message
|
||||
(begin (tc/funapp1 f-stx args-stx
|
||||
(make-arr (car pdoms) (car rngs)
|
||||
(car rests) (car drests) null)
|
||||
arg-tys expected)
|
||||
return)
|
||||
;; if not, print the message as usual
|
||||
(let* ([pdoms (map make-printable pdoms)]
|
||||
[err-doms
|
||||
(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
|
||||
|
|
@ -177,7 +248,8 @@
|
|||
(let ([fun-tys-ret-any
|
||||
(map (match-lambda
|
||||
[(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)])
|
||||
(let loop ([cases fun-tys-ret-any]
|
||||
[parts parts-acc]
|
||||
|
|
@ -200,7 +272,7 @@
|
|||
orig
|
||||
(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
|
||||
[(or (Poly-names:
|
||||
msg-vars
|
||||
|
|
@ -218,13 +290,16 @@
|
|||
"Could not infer types for applying polymorphic "
|
||||
fcn-string
|
||||
"\n"))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
(string-append
|
||||
"Polymorphic " fcn-string " could not be applied to arguments:\n"
|
||||
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected)
|
||||
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
|
||||
(string-append "Type Variables: " (stringify msg-vars) "\n")
|
||||
"")))))]
|
||||
(domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests
|
||||
msg-rngs argtypes #f #f #:expected expected
|
||||
#:return (ret (Un))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"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) ...)))
|
||||
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))))
|
||||
(let ([fcn-string (if name
|
||||
|
|
@ -237,10 +312,13 @@
|
|||
"Could not infer types for applying polymorphic "
|
||||
fcn-string
|
||||
"\n"))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
(string-append
|
||||
"Polymorphic " fcn-string " could not be applied to arguments:\n"
|
||||
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected)
|
||||
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
|
||||
(string-append "Type Variables: " (stringify msg-vars) "\n")
|
||||
"")))))]))
|
||||
(domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests
|
||||
msg-rngs argtypes #f #f #:expected expected
|
||||
#:return (ret (Un))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"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")
|
||||
""))))))]))
|
||||
|
|
|
|||
|
|
@ -137,15 +137,19 @@
|
|||
(match a
|
||||
[(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))])
|
||||
(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)))
|
||||
(string-append "No function domains matched in function application:\n"
|
||||
(domain-mismatches arities doms rests drests rngs
|
||||
(map tc-expr (syntax->list pos-args))
|
||||
#f #f #:expected expected)))
|
||||
(tc/funapp (car (syntax-e form)) kw-args
|
||||
(ret (make-Function new-arities))
|
||||
(map tc-expr (syntax->list pos-args)) expected)))]))
|
||||
#:msg-thunk
|
||||
(lambda (dom)
|
||||
(string-append "No function domains matched in function application:\n"
|
||||
dom)))
|
||||
(tc/funapp (car (syntax-e form)) kw-args
|
||||
(ret (make-Function new-arities))
|
||||
(map tc-expr (syntax->list pos-args)) expected)))]))
|
||||
|
||||
(define (type->list t)
|
||||
(match t
|
||||
|
|
|
|||
|
|
@ -40,21 +40,24 @@
|
|||
|
||||
(match f-ty
|
||||
;; 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)
|
||||
(when (null? doms)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"empty case-lambda given as argument to apply"))
|
||||
(match-let ([arg-tys (map tc-expr/t fixed-args)]
|
||||
[(tc-result1: tail-ty) (single-value tail)])
|
||||
(match-let* ([arg-tres (map tc-expr fixed-args)]
|
||||
[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])
|
||||
(cond
|
||||
;; we've run out of cases to try, so error out
|
||||
[(null? doms*)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
(string-append
|
||||
"Bad arguments to function in apply:\n"
|
||||
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty #f)))]
|
||||
(domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f
|
||||
#:return (ret (Un))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"Bad arguments to function in apply:\n"
|
||||
dom)))]
|
||||
;; this case of the function type has a rest argument
|
||||
[(and (car rests*)
|
||||
;; 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*))])))]
|
||||
;; apply of simple polymorphic function
|
||||
[(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)
|
||||
[(ListDots: tail-ty tail-bound)
|
||||
(values tail-ty tail-bound)]
|
||||
|
|
@ -84,11 +88,13 @@
|
|||
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
|
||||
(cond [(null? doms*)
|
||||
(match f-ty
|
||||
[(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
(string-append
|
||||
"Bad arguments to polymorphic function in apply:\n"
|
||||
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
|
||||
[(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 tail-ty tail-bound
|
||||
#:return (ret (Un))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"Bad arguments to polymorphic function in apply:\n"
|
||||
dom)))])]
|
||||
;; the actual work, when we have a * function and a list final argument
|
||||
[(and (car rests*)
|
||||
(not tail-bound)
|
||||
|
|
@ -129,7 +135,8 @@
|
|||
"Function has no cases")]
|
||||
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
|
||||
(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)
|
||||
[(ListDots: tail-ty tail-bound)
|
||||
(values tail-ty tail-bound)]
|
||||
|
|
@ -138,11 +145,13 @@
|
|||
(define (finish substitution) (do-ret (subst-all substitution (car rngs*))))
|
||||
(cond [(null? doms*)
|
||||
(match f-ty
|
||||
[(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
(string-append
|
||||
"Bad arguments to polymorphic function in apply:\n"
|
||||
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
|
||||
[(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 tail-ty tail-bound
|
||||
#:return (ret (Un))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"Bad arguments to polymorphic function in apply:\n"
|
||||
dom)))])]
|
||||
;; the actual work, when we have a * function and a list final argument
|
||||
[(and (car rests*)
|
||||
(not tail-bound)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,8 @@
|
|||
(require (rename-in "../utils/utils.rkt" [infer r:infer])
|
||||
"signatures.rkt" "tc-metafunctions.rkt"
|
||||
"tc-app-helper.rkt" "find-annotation.rkt"
|
||||
"tc-subst.rkt" "check-below.rkt"
|
||||
(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
|
||||
racket/bool racket/unsafe/ops
|
||||
(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)
|
||||
(utils tc-utils)
|
||||
(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)
|
||||
'#%paramz
|
||||
(for-template
|
||||
|
|
@ -37,7 +36,7 @@
|
|||
(let ([substitution (infer vars ... a)])
|
||||
(and substitution
|
||||
(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)
|
||||
(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
|
||||
(tc/funapp1 f-stx args-stx a argtys expected #:check #f))
|
||||
;; if nothing matched, error
|
||||
(tc-error/expr
|
||||
#:return (or expected (ret (Un)))
|
||||
(string-append "No function domains matched in function application:\n"
|
||||
(domain-mismatches t doms rests drests rngs argtys-t #f #f #:expected expected))))]
|
||||
(domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f
|
||||
#:expected expected #:return (or expected (ret (Un)))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append "No function domains matched in function application:\n"
|
||||
dom))))]
|
||||
;; any kind of dotted polymorphic function without mandatory keyword args
|
||||
[((tc-result1: (and t (PolyDots:
|
||||
(and vars (list fixed-vars ... dotted-var))
|
||||
|
|
@ -127,41 +127,3 @@
|
|||
[((tc-result1: f-ty) _)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"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)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user