diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index d0752ee6..0818d2a5 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -570,7 +570,7 @@ [(values t ...) #:when (eq? 'values (syntax-e #'values)) (ret (map parse-type (syntax->list #'(t ...))))] - [t (parse-type #'t)])) + [t (ret (parse-type #'t))])) (define parse-tc-results/id (parse/id parse-tc-results)) diff --git a/collects/typed-scheme/test2.ss b/collects/typed-scheme/test2.ss index 43523217..d895c3b5 100644 --- a/collects/typed-scheme/test2.ss +++ b/collects/typed-scheme/test2.ss @@ -1,13 +1,24 @@ #lang typed-scheme (: f (Number String -> Number)) -(define (f x z) (f x z)) +(define (f x z) #;(f x z) 7) (lambda: ([x : Any] [y : Any]) (values (number? y) (number? x))) (lambda: ([x : Any] [y : Any]) (values (number? x) (number? y))) (lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y))) (lambda: ([x : Any]) (values (number? x) (number? x))) (: g (Any -> Boolean : Number)) (define g (lambda: ([x : Any]) (number? x))) +(: q ((Number -> Number) -> Number)) +(define q (lambda: ([x : (Number -> Number)]) (x 1))) +;(q (lambda (z) (f z "foo"))) + +(: p (Number * -> Number)) +(define (p . x) 7) + +(lambda x (number? x)) +(+) +(+ 1 2 3) +(+ 1 2 3.5) ;(f 12 "hi") diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss new file mode 100644 index 00000000..f5f268e9 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -0,0 +1,41 @@ +#lang scheme/base + +(require "../utils/utils.ss" + (utils tc-utils)) + +(provide (all-defined-out)) + +(define (stringify-domain dom rst drst [rng #f]) + (let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))] + [rng-string (if rng (format " -> ~a" rng) "")]) + (cond [drst + (format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)] + [rst + (format "~a~a *~a" doms-string rst rng-string)] + [else (string-append (stringify dom) rng-string)]))) + +(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f]) + (define arguments-str + (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f))) + (cond + [(null? doms) + (int-err "How could doms be null: ~a ~a" ty)] + [(= 1 (length doms)) + (format "Domain: ~a~nArguments: ~a~n~a" + (stringify-domain (car doms) (car rests) (car drests)) + arguments-str + (if expected + (format "Result type: ~a~nExpected result: ~a~n" + (car rngs) expected) + ""))] + [else + (format "~a: ~a~nArguments: ~a~n~a" + (if expected "Types" "Domains") + (stringify (if expected + (map stringify-domain doms rests drests rngs) + (map stringify-domain doms rests drests)) + "~n\t") + arguments-str + (if expected + (format "Expected result: ~a~n" expected) + ""))])) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 155196cd..eee6b699 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -2,9 +2,10 @@ (require (rename-in "../utils/utils.ss" [infer r:infer]) "signatures.ss" "tc-metafunctions.ss" + "tc-app-helper.ss" stxclass scheme/match mzlib/trace (for-syntax stxclass) - (types utils abbrev) + (types utils abbrev union subtype) (utils tc-utils) (rep type-rep filter-rep object-rep) (for-template @@ -88,24 +89,48 @@ (define (in-indexes dom) (in-range (length dom))) -;; syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results) -> tc-results? (define (tc/funapp f-stx args-stx ftype0 argtys expected) (match* (ftype0 argtys) - [((tc-result1: (Function: (list (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) #f #f '())))) + ;; we special-case this (no case-lambda) for improved error messages + [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws)))))) + argtys) + (tc/funapp1 f-stx args-stx a argtys expected)] + [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests #f kws) ...))))) + (and argtys (list (tc-result1: argtys-t) ...))) + (let loop ([doms* doms] [rngs rngs] [rests* rests] [a arrs]) + (cond [(null? doms*) + (tc-error/expr + #:return (or expected (ret (Un))) + (string-append "No function domains matched in function application:\n" + (domain-mismatches t doms rests #f rngs argtys #f #f)))] + [(subtypes/varargs argtys-t (car doms*) (car rests*)) + (tc/funapp1 f-stx args-stx (car a) argtys expected #:check #f)] + [else (loop (cdr doms*) (cdr rngs) (cdr rests*) (cdr a))]))])) + + +;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? +(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) + (match* (ftype0 argtys) + [((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f '()) (list (tc-result1: t-a phi-a o-a) ...)) - (unless (= (length dom) (length t-a)) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments")) - (for ([dom-t (in-list dom)] [arg-t (in-list t-a)]) - (check-below arg-t dom-t)) + (when check? + (cond [(and (not rest) (not (= (length dom) (length t-a)))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] + [(and rest (< (length t-a) (length dom))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) + (for ([dom-t (in-list-forever dom rest)] [a (syntax->list args-stx)] [arg-t (in-list t-a)]) + (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (let* (;; Listof[Listof[LFilterSet]] [lfs-f (for/list ([lf lf-r]) - (for/list ([i (in-indexes dom)]) - (split-lfilters lf i)))] + (for/list ([i (in-indexes dom)]) + (split-lfilters lf i)))] ;; Listof[FilterSet] [f-r (for/list ([lfs lfs-f]) - (merge-filter-sets (for/list ([lf lfs] [t t-a] [o o-a]) - (apply-filter lf t o))))] + (merge-filter-sets + (for/list ([lf lfs] [t t-a] [o o-a]) + (apply-filter lf t o))))] ;; Listof[Object] [o-r (for/list ([lo lo-r]) (match lo @@ -116,4 +141,4 @@ [_ (make-Empty)]))]) (ret t-r f-r o-r))] [(_ _) - (int-err "funapp with keyword/rest args NYI")])) \ No newline at end of file + (int-err "funapp with keyword args NYI")])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 6119c29f..59080124 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -5,7 +5,7 @@ "tc-metafunctions.ss" mzlib/trace scheme/list - stxclass/util + stxclass/util syntax/stx (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c]) (except-in (rep type-rep) make-arr) (rename-in (types convenience utils union) @@ -160,10 +160,11 @@ #f (tc-exprs (syntax->list body)))))]))])) - -;; FIXED TO HERE - -;(trace tc-args) +(define (formals->list l) + (let loop ([l (syntax-e l)]) + (cond [(stx-pair? l) (cons (stx-car l) (loop (stx-cdr l)))] + [(pair? l) (cons (car l) (loop (cdr l)))] + [else null]))) ;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result) ;; typecheck a sequence of case-lambda clauses @@ -200,7 +201,7 @@ [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) - args (values->tc-results ret (syntax->list (car (syntax->list formals)))) rest drest))] + args (values->tc-results ret (formals->list (car (syntax->list formals)))) rest drest))] [_ (go (syntax->list formals) (syntax->list bodies) null null null)]))] ;; otherwise [else (go (syntax->list formals) (syntax->list bodies) null null null)]))