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

Support ValuesDots in a typechecking a funapp

Browse Source 
Closes PR 13651
This commit is contained in:
Asumu Takikawa 2014-02-24 00:26:11 -05:00
parent 262fad814a
commit 4f3c98f754
3 changed files with 35 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -19,14 +19,19 @@
(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) (define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
(match* (ftype0 argtys) (match* (ftype0 argtys)
;; we check that all kw args are optional ;; we check that all kw args are optional
[((arr: dom (and rng (or (AnyValues:) (Values: _))) rest #f (and kws (list (Keyword: _ _ #f) ...))) [((arr: dom rng rest #f (and kws (list (Keyword: _ _ #f) ...)))
(list (tc-result1: t-a phi-a o-a) ...)) (list (tc-result1: t-a phi-a o-a) ...))
(when check? (when check?
(define error-ret (define error-ret
(match rng (match rng
((AnyValues:) tc-any-results) ((AnyValues:) tc-any-results)
((Values: (list (Result: t-r _ _) ...)) (ret t-r)))) ((Values: (list (Result: t-r _ _) ...)) (ret t-r))
((ValuesDots: (list (Result: t-r _ _) ...) dty dbound)
(ret t-r
(make-list (length t-r) -no-filter)
(make-list (length t-r) -no-obj)
dty dbound))))
(cond [(and (not rest) (not (= (length dom) (length t-a)))) (cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/expr #:return error-ret (tc-error/expr #:return error-ret
"Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
@ -53,7 +58,13 @@
(for/lists (t-r f-r o-r) (for/lists (t-r f-r o-r)
([r (in-list results)]) ([r (in-list results)])
(open-Result r o-a t-a))) (open-Result r o-a t-a)))
(ret t-r f-r o-r)))))] (ret t-r f-r o-r))
((ValuesDots: results dty dbound)
(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 dty dbound)))))]
;; this case should only match if the function type has mandatory keywords ;; this case should only match if the function type has mandatory keywords
;; but no keywords were provided in the application ;; but no keywords were provided in the application
[((arr: _ _ _ _ [((arr: _ _ _ _

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -507,7 +507,12 @@
(let* ([ts* (do-inst form ts)] (let* ([ts* (do-inst form ts)]
[r (ret ts* fs os)]) [r (ret ts* fs os)])
(add-typeof-expr form r) (add-typeof-expr form r)
r)]))]))) r)]
[(tc-results: ts fs os dty dbound)
(define ts* (do-inst form ts))
(define r (ret ts* fs os dty dbound))
(add-typeof-expr form r)
r]))])))
(define (single-value form [expected #f]) (define (single-value form [expected #f])
(define t (if expected (tc-expr/check form expected) (tc-expr form))) (define t (if expected (tc-expr/check form expected) (tc-expr form)))

15
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2302,6 +2302,21 @@
(-filter (-val #f) (list 0 0))) (-filter (-val #f) (list 0 0)))
: (make-Path null (list 0 0)))) : (make-Path null (list 0 0))))
(-FS -top -bot))] (-FS -top -bot))]
;; PR 13651 and related
[tc-e (tr:lambda #:forall (a ...) ([f : (-> String (values a ... a))])
(f "foo"))
#:ret (ret (-polydots (a)
(t:-> (t:-> -String (make-ValuesDots '() a 'a))
(make-ValuesDots '() a 'a)))
(-FS -top -bot))]
[tc-e (inst (plambda: (A B ...) ((a : A) b : B ... B)
((ann (lambda () (apply (inst values A B ... B) a b))
(-> (values A B ... B)))))
String String Symbol)
#:ret (ret (t:-> -String -String -Symbol
(-values (list -String -String -Symbol)))
(-FS -top -bot))]
) )
(test-suite (test-suite
"tc-literal tests" "tc-literal tests"