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

Make funapp take a Type/c instead of a tc-results?.

Browse Source
This commit is contained in:
Eric Dobson 2014-05-18 20:37:31 -07:00
parent cb243606ab
commit 5af90e65e9
10 changed files with 30 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -50,9 +50,9 @@
(let loop ((t t)) (let loop ((t t))
(match t (match t
[(Function: (list _ ... (arr: (list arg1) _ _ #f (list (Keyword: _ _ #f) ...)) _ ...)) [(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) ...)) _ ...)) [(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) [(? needs-resolving? t)
(loop (resolve t))] (loop (resolve t))]
[(or (Poly: ns _) (PolyDots: (list ns ... _) _)) [(or (Poly: ns _) (PolyDots: (list ns ... _) _))

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
View File

@ -27,7 +27,7 @@
(define-tc/app-syntax-class (tc/app-eq expected) (define-tc/app-syntax-class (tc/app-eq expected)
(pattern (eq?:comparator v1 v2) (pattern (eq?:comparator v1 v2)
;; make sure the whole expression is type correct ;; 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) (stx-map single-value #'(v1 v2)) expected)
;; check thn and els with the eq? info ;; check thn and els with the eq? info
(tc/eq #'eq? #'v1 #'v2)) (tc/eq #'eq? #'v1 #'v2))

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -95,7 +95,7 @@
[(list (and a (arr: dom rng rest #f ktys))) [(list (and a (arr: dom rng rest #f ktys)))
(tc-keywords/internal a kws kw-args #t) (tc-keywords/internal a kws kw-args #t)
(tc/funapp (car (syntax-e form)) kw-args (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)] (stx-map tc-expr pos-args) expected)]
[(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...) [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...)
(let ([new-arities (let ([new-arities
@ -115,7 +115,7 @@
(string-append "No function domains matched in function application:\n" (string-append "No function domains matched in function application:\n"
dom))) dom)))
(tc/funapp (car (syntax-e form)) kw-args (tc/funapp (car (syntax-e form)) kw-args
(ret (make-Function new-arities)) (make-Function new-arities)
(stx-map tc-expr pos-args) expected)))])) (stx-map tc-expr pos-args) expected)))]))
(define (type->list t) (define (type->list t)

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -52,7 +52,7 @@
[(tc-result1: (Listof: elem-type)) (ret elem-type)] [(tc-result1: (Listof: elem-type)) (ret elem-type)]
[else (fail)])) [else (fail)]))
;; Do not check this in an environment where bound0 is a type variable. ;; 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 ;; 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 ;; We need the bound to be considered a type var here so that inference works
(match (extend-tvars (list bound0) (match (extend-tvars (list bound0)
@ -67,7 +67,7 @@
;; ormap/andmap of ... argument ;; ormap/andmap of ... argument
(pattern (~and form (m:boolmap f arg)) (pattern (~and form (m:boolmap f arg))
(match-let* ([arg-ty (tc-expr/t #'arg)] (match-let* ([arg-ty (tc-expr/t #'arg)]
[ft (tc-expr #'f)]) [ft (tc-expr/t #'f)])
(match (match arg-ty (match (match arg-ty
;; if the argument is a ListDots ;; if the argument is a ListDots
[(ListDots: t bound) [(ListDots: t bound)
@ -113,4 +113,4 @@
[(tc-result1: (List: ts)) [(tc-result1: (List: ts))
(ret (-Tuple (reverse ts)))] (ret (-Tuple (reverse ts)))]
[arg-ty [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)])])))

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -67,7 +67,7 @@
(define (tc/app-regular form expected) (define (tc/app-regular form expected)
(syntax-case form () (syntax-case form ()
[(f . args) [(f . args)
(let* ([f-ty (single-value #'f)] (let* ([f-ty (tc-expr/t #'f)]
[args* (syntax->list #'args)]) [args* (syntax->list #'args)])
(define (matching-arities arrs) (define (matching-arities arrs)
(for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr)) (for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr))
@ -77,12 +77,11 @@
(define arg-tys (define arg-tys
(match f-ty (match f-ty
[(tc-result1: (Function: (? has-drest/filter?))) [(Function: (? has-drest/filter?))
(map single-value args*)] (map single-value args*)]
[(tc-result1: [(Function:
(Function: (app matching-arities
(app matching-arities (list (arr: doms ranges rests drests _) ..1)))
(list (arr: doms ranges rests drests _) ..1))))
(define matching-domains (define matching-domains
(in-values-sequence (in-values-sequence
(apply in-parallel (apply in-parallel

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -44,9 +44,9 @@
[(tc-result1: (and t Poly?)) [(tc-result1: (and t Poly?))
(tc-expr/check #'quo (ret Univ)) (tc-expr/check #'quo (ret Univ))
(tc/funapp #'op #'(quo arg) (tc/funapp #'op #'(quo arg)
(ret (instantiate-poly t (extend (list Univ Univ) (instantiate-poly t (extend (list Univ Univ)
(stx-map type-annotation #'(i ...)) (stx-map type-annotation #'(i ...))
Univ))) Univ))
(list (ret Univ) (single-value #'arg)) (list (ret Univ) (single-value #'arg))
expected)])) expected)]))
;; special-case for not - flip the filters ;; special-case for not - flip the filters

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -19,9 +19,9 @@
#:literal-sets (values-literals) #:literal-sets (values-literals)
;; call-with-values ;; call-with-values
(pattern (call-with-values prod con) (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-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-any-results: _)
(tc/app-regular this-syntax expected)])) (tc/app-regular this-syntax expected)]))
;; special case for `values' with single argument ;; special case for `values' with single argument

15
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
View File

@ -13,7 +13,7 @@
(provide/cond-contract (provide/cond-contract
[tc/funapp [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:or/c #f tc-results/c)
. c:-> . full-tc-results/c)]) . c:-> . full-tc-results/c)])
@ -32,10 +32,8 @@
#:name (and (identifier? f-stx) f-stx) #:name (and (identifier? f-stx) f-stx)
#:expected expected))))])) #:expected expected))))]))
(define (tc/funapp f-stx args-stx f-type args-res expected)
(define (tc/funapp f-stx args-stx f-res args-res expected)
(match-define (list (tc-result1: argtys) ...) args-res) (match-define (list (tc-result1: argtys) ...) args-res)
(match-define (tc-result1: f-type f-filter f-object) f-res)
(match f-type (match f-type
;; we special-case this (no case-lambda) for improved error messages ;; we special-case this (no case-lambda) for improved error messages
;; tc/funapp1 currently cannot handle drest arities ;; tc/funapp1 currently cannot handle drest arities
@ -134,13 +132,13 @@
(define substitution (define substitution
(hash row-var (hash row-var
(t-subst (infer-row constraints resolved-argty)))) (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)] args-res expected)]
[else (fail)])] [else (fail)])]
;; procedural structs ;; procedural structs
[(Struct: _ _ _ (? Function? proc-ty) _ _) [(Struct: _ _ _ (? Function? proc-ty) _ _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) proc-ty
(cons f-res args-res) expected)] (cons (ret f-type) args-res) expected)]
;; parameters are functions too ;; parameters are functions too
[(Param: in out) [(Param: in out)
(match argtys (match argtys
@ -156,9 +154,8 @@
"Wrong number of arguments to parameter - expected 0 or 1, got ~a" "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))])] (length argtys))])]
;; resolve names, polymorphic apps, mu, etc ;; resolve names, polymorphic apps, mu, etc
;; TODO figure out what needs the filter and object of the function
[(? needs-resolving?) [(? 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 ;; a union of functions can be applied if we can apply all of the elements
[(Union: (and ts (list (Function: _) ...))) [(Union: (and ts (list (Function: _) ...)))
(merge-tc-results (merge-tc-results

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -28,7 +28,7 @@
"method name" s "method name" s
"object type" obj "object type" obj
#:return -Bottom)])) #: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" [_ (int-err "non-symbol methods not supported by Typed Racket: ~a"
rcvr-type)])] rcvr-type)])]
;; union of objects, check pointwise and union the results ;; union of objects, check pointwise and union the results

5
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-result.rkt
View File

@ -20,6 +20,10 @@
(or (tc-results? v) (or (tc-results? v)
(tc-any-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. ;; 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. ;; Used to contract the return values of typechecking functions.
(define (full-tc-results/c r) (define (full-tc-results/c r)
@ -160,4 +164,5 @@
[tc-result-equal? (tc-result? tc-result? . c:-> . boolean?)] [tc-result-equal? (tc-result? tc-result? . c:-> . boolean?)]
[tc-results? (c:any/c . c:-> . boolean?)] [tc-results? (c:any/c . c:-> . boolean?)]
[tc-results/c c:flat-contract?] [tc-results/c c:flat-contract?]
[tc-results1/c c:flat-contract?]
[full-tc-results/c c:flat-contract?]) [full-tc-results/c c:flat-contract?])