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

Support case-lambda with multiple branches with keyword arguments.

Browse Source 
original commit: 78832fe332fccfe7c533243c4e1f1c1d0e3753e4
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-08 17:31:07 -04:00
parent f315f666d5
commit 2ddda6b00a
3 changed files with 64 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/tests/typed-scheme/succeed/kw.rkt
View File

@ -4,3 +4,11 @@
(open-input-file "foo" #:mode 'binary)
(open-input-file "foo" #:mode 'text)
(open-input-file "foo"))
((inst sort Real Real) (list 1 2 3) >)
((inst sort Real Real) (list 1 2 3) #:key (λ: ([x : Real]) (/ 1 x)) >)
((inst sort Real String) (list 1 2 3) #:key number->string string<?)
((inst sort Real String) (list 1 2 3) #:key number->string string<? #:cache-keys? #t)

8
collects/typed-scheme/private/base-env.rkt
View File

@ -630,7 +630,13 @@
[list->string ((-lst -Char) . -> . -String)]
[string->list (-String . -> . (-lst -Char))]
[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))]
[sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B)
#:cache-keys? B #f
. ->key . (-lst a))
((-lst a) (b b . -> . B)
#:key (a . -> . b) #t
#:cache-keys? B #f
. ->key . (-lst a))))]
[find-system-path (Sym . -> . -Path)]
[object-name (Univ . -> . Univ)]

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

@ -78,9 +78,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keywords
(define (tc-keywords form arities kws kw-args pos-args expected)
(match arities
[(list (arr: dom rng rest #f ktys))
(define (tc-keywords/internal arity kws kw-args error?)
(match arity
[(arr: dom rng rest #f ktys)
;; assumes that everything is in sorted order
(let loop ([actual-kws kws]
[actuals (map tc-expr/t (syntax->list kw-args))]
@ -89,28 +89,59 @@
[('() '())
(void)]
[(_ '())
(tc-error/expr #:return (ret (Un))
"Unexpected keyword argument ~a" (car actual-kws))]
(if error?
(tc-error/expr #:return (ret (Un))
"Unexpected keyword argument ~a" (car actual-kws))
#f)]
[('() (cons fst rst))
(match fst
[(Keyword: k _ #t)
(tc-error/expr #:return (ret (Un))
"Missing keyword argument ~a" k)]
(if error?
(tc-error/expr #:return (ret (Un))
"Missing keyword argument ~a" k)
#f)]
[_ (loop actual-kws actuals rst)])]
[((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))
(cond [(eq? k k*) ;; we have a match
(unless (subtype (car actuals) t)
(tc-error/delayed
"Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
t (car actuals) k))
(loop kws-rest (cdr actuals) form-rest)]
(cond [(eq? k k*) ;; we have a match
(if (subtype (car actuals) t)
;; success
(loop kws-rest (cdr actuals) form-rest)
;; failure
(and error?
(tc-error/delayed
"Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
t (car actuals) k)
(loop kws-rest (cdr actuals) form-rest)))]
[req? ;; this keyword argument was required
(tc-error/delayed "Missing keyword argument ~a" k*)
(loop kws-rest (cdr actuals) form-rest)]
(if error?
(begin (tc-error/delayed "Missing keyword argument ~a" k*)
(loop kws-rest (cdr actuals) form-rest))
#f)]
[else ;; otherwise, ignore this formal param, and continue
(loop actual-kws actuals form-rest)])]))
(tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)]
[_ (int-err "case-lambda w/ keywords not supported")]))
(loop actual-kws actuals form-rest)])]))]))
(define (tc-keywords form arities kws kw-args pos-args expected)
(match arities
[(list (and a (arr: dom rng rest #f ktys)))
(tc-keywords/internal a kws kw-args #t)
(tc/funapp (car (syntax-e form)) kw-args
(ret (make-Function (list (make-arr* dom rng #:rest rest))))
(map tc-expr (syntax->list pos-args)) expected)]
[(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...)
(let ([new-arities
(for/list ([a (in-list arities)]
;; find all the arities where the keywords match
#:when (tc-keywords/internal a kws kw-args #f))
(match a
[(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))])
(if (null? new-arities)
(tc-error/expr
#: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)))
(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