From 7b1b0d2a1f712bf95faaeef05d7f7b1d5b9a3639 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 18 May 2014 20:37:31 -0700 Subject: [PATCH] Make funapp take a Type/c instead of a tc-results?. original commit: 5af90e65e9d6e1ee8307a848d705b0f5e56528c4 --- .../typecheck/check-subforms-unit.rkt | 4 ++-- .../typed-racket/typecheck/tc-app/tc-app-eq.rkt | 2 +- .../typecheck/tc-app/tc-app-keywords.rkt | 4 ++-- .../typed-racket/typecheck/tc-app/tc-app-list.rkt | 6 +++--- .../typed-racket/typecheck/tc-app/tc-app-main.rkt | 11 +++++------ .../typecheck/tc-app/tc-app-special.rkt | 6 +++--- .../typecheck/tc-app/tc-app-values.rkt | 4 ++-- .../typed-racket/typecheck/tc-funapp.rkt | 15 ++++++--------- .../typed-racket/typecheck/tc-send.rkt | 2 +- .../typed-racket/types/tc-result.rkt | 5 +++++ 10 files changed, 30 insertions(+), 29 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt index 4753cc03..175fd62b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt @@ -50,9 +50,9 @@ (let loop ((t t)) (match t [(Function: (list _ ... (arr: (list arg1) _ _ #f (list (Keyword: _ _ #f) ...)) _ ...)) - (tc/funapp #'here #'(here) (ret t) (list (ret arg1)) #f)] + (tc/funapp #'here #'(here) t (list (ret arg1)) #f)] [(Function: (list _ ... (arr: '() _ (? values rest) #f (list (Keyword: _ _ #f) ...)) _ ...)) - (tc/funapp #'here #'(here) (ret t) (list (ret rest)) #f)] + (tc/funapp #'here #'(here) t (list (ret rest)) #f)] [(? needs-resolving? t) (loop (resolve t))] [(or (Poly: ns _) (PolyDots: (list ns ... _) _)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt index af8e626c..4bca1593 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt @@ -27,7 +27,7 @@ (define-tc/app-syntax-class (tc/app-eq expected) (pattern (eq?:comparator v1 v2) ;; make sure the whole expression is type correct - (match* ((tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) + (match* ((tc/funapp #'eq? #'(v1 v2) (tc-expr/t #'eq?) (stx-map single-value #'(v1 v2)) expected) ;; check thn and els with the eq? info (tc/eq #'eq? #'v1 #'v2)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt index ea0a761a..7fc378b0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -95,7 +95,7 @@ [(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)))) + (->* dom rest rng) (stx-map tc-expr pos-args) expected)] [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...) (let ([new-arities @@ -115,7 +115,7 @@ (string-append "No function domains matched in function application:\n" dom))) (tc/funapp (car (syntax-e form)) kw-args - (ret (make-Function new-arities)) + (make-Function new-arities) (stx-map tc-expr pos-args) expected)))])) (define (type->list t) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt index cdf59b3c..0f22f3ed 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt @@ -52,7 +52,7 @@ [(tc-result1: (Listof: elem-type)) (ret elem-type)] [else (fail)])) ;; Do not check this in an environment where bound0 is a type variable. - (define f-type (tc-expr #'f)) + (define f-type (tc-expr/t #'f)) ;; Check that the function applies successfully to the element type ;; We need the bound to be considered a type var here so that inference works (match (extend-tvars (list bound0) @@ -67,7 +67,7 @@ ;; ormap/andmap of ... argument (pattern (~and form (m:boolmap f arg)) (match-let* ([arg-ty (tc-expr/t #'arg)] - [ft (tc-expr #'f)]) + [ft (tc-expr/t #'f)]) (match (match arg-ty ;; if the argument is a ListDots [(ListDots: t bound) @@ -113,4 +113,4 @@ [(tc-result1: (List: ts)) (ret (-Tuple (reverse ts)))] [arg-ty - (tc/funapp #'fun #'(arg) (single-value #'fun) (list arg-ty) expected)])]))) + (tc/funapp #'fun #'(arg) (tc-expr/t #'fun) (list arg-ty) expected)])]))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt index a6469364..c2a8c026 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt @@ -67,7 +67,7 @@ (define (tc/app-regular form expected) (syntax-case form () [(f . args) - (let* ([f-ty (single-value #'f)] + (let* ([f-ty (tc-expr/t #'f)] [args* (syntax->list #'args)]) (define (matching-arities arrs) (for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr)) @@ -77,12 +77,11 @@ (define arg-tys (match f-ty - [(tc-result1: (Function: (? has-drest/filter?))) + [(Function: (? has-drest/filter?)) (map single-value args*)] - [(tc-result1: - (Function: - (app matching-arities - (list (arr: doms ranges rests drests _) ..1)))) + [(Function: + (app matching-arities + (list (arr: doms ranges rests drests _) ..1))) (define matching-domains (in-values-sequence (apply in-parallel diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt index 0ab5caa6..933b1fef 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt @@ -44,9 +44,9 @@ [(tc-result1: (and t Poly?)) (tc-expr/check #'quo (ret Univ)) (tc/funapp #'op #'(quo arg) - (ret (instantiate-poly t (extend (list Univ Univ) - (stx-map type-annotation #'(i ...)) - Univ))) + (instantiate-poly t (extend (list Univ Univ) + (stx-map type-annotation #'(i ...)) + Univ)) (list (ret Univ) (single-value #'arg)) expected)])) ;; special-case for not - flip the filters diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt index cde15892..77fd3baf 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt @@ -19,9 +19,9 @@ #:literal-sets (values-literals) ;; call-with-values (pattern (call-with-values prod con) - (match (tc/funapp #'prod #'() (single-value #'prod) null #f) + (match (tc/funapp #'prod #'() (tc-expr/t #'prod) null #f) [(tc-results: ts fs os) - (tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)] + (tc/funapp #'con #'(prod) (tc-expr/t #'con) (map ret ts fs os) expected)] [(tc-any-results: _) (tc/app-regular this-syntax expected)])) ;; special case for `values' with single argument diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt index 9f022cd2..ac33893b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt @@ -13,7 +13,7 @@ (provide/cond-contract [tc/funapp - (syntax? stx-list? tc-results/c (c:listof tc-results/c) + (syntax? stx-list? Type/c (c:listof tc-results1/c) (c:or/c #f tc-results/c) . c:-> . full-tc-results/c)]) @@ -32,10 +32,8 @@ #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) - -(define (tc/funapp f-stx args-stx f-res args-res expected) +(define (tc/funapp f-stx args-stx f-type args-res expected) (match-define (list (tc-result1: argtys) ...) args-res) - (match-define (tc-result1: f-type f-filter f-object) f-res) (match f-type ;; we special-case this (no case-lambda) for improved error messages ;; tc/funapp1 currently cannot handle drest arities @@ -134,13 +132,13 @@ (define substitution (hash row-var (t-subst (infer-row constraints resolved-argty)))) - (tc/funapp f-stx args-stx (ret (subst-all substitution f-ty)) + (tc/funapp f-stx args-stx (subst-all substitution f-ty) args-res expected)] [else (fail)])] ;; procedural structs [(Struct: _ _ _ (? Function? proc-ty) _ _) - (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) - (cons f-res args-res) expected)] + (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) proc-ty + (cons (ret f-type) args-res) expected)] ;; parameters are functions too [(Param: in out) (match argtys @@ -156,9 +154,8 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtys))])] ;; resolve names, polymorphic apps, mu, etc - ;; TODO figure out what needs the filter and object of the function [(? needs-resolving?) - (tc/funapp f-stx args-stx (ret (resolve-once f-type) f-filter f-object) args-res expected)] + (tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)] ;; a union of functions can be applied if we can apply all of the elements [(Union: (and ts (list (Function: _) ...))) (merge-tc-results diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt index 7aa01601..bc037c74 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt @@ -28,7 +28,7 @@ "method name" s "object type" obj #:return -Bottom)])) - (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)] + (tc/funapp rcvr args ftype (stx-map tc-expr args) expected)] [_ (int-err "non-symbol methods not supported by Typed Racket: ~a" rcvr-type)])] ;; union of objects, check pointwise and union the results diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt index 3d6c9e40..40e2fa85 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt @@ -20,6 +20,10 @@ (or (tc-results? v) (tc-any-results? v))) +(define (tc-results1/c v) + (and (tc-results? v) + (= (length (tc-results-ts v)) 1))) + ;; Contract to check that values are tc-results/c and do not contain -no-filter or -no-obj. ;; Used to contract the return values of typechecking functions. (define (full-tc-results/c r) @@ -160,4 +164,5 @@ [tc-result-equal? (tc-result? tc-result? . c:-> . boolean?)] [tc-results? (c:any/c . c:-> . boolean?)] [tc-results/c c:flat-contract?] + [tc-results1/c c:flat-contract?] [full-tc-results/c c:flat-contract?])