suzanne.soy/typed-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 
original commit: 5af90e65e9d6e1ee8307a848d705b0f5e56528c4
This commit is contained in:
Eric Dobson 2014-05-18 20:37:31 -07:00
parent fc62fad0bc
commit 7b1b0d2a1f
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))
(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 ... _) _))

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)
(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))

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)))
(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)

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)]
[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)])])))

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)
(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

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-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

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)
;; 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

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

@ -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

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

@ -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

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

@ -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?])