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

Make tc-error/expr return (ret -Bottom).

Browse Source 
original commit: ca3411155f4257e890cb2eb52d0ab1896e0199ea
This commit is contained in:
Eric Dobson 2014-03-20 09:32:25 -07:00
parent a79ba7561d
commit 9a7e34674f
14 changed files with 55 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt
View File

@ -108,10 +108,9 @@
(let ([ty (tc-expr expr)])
(match ty
[(tc-any-results:)
(ret
(tc-error/expr
"Expression should produce ~a values, but produces an unknown number of values"
(length stxs)))]
(tc-error/expr
"Expression should produce ~a values, but produces an unknown number of values"
(length stxs))]
[(tc-results: tys fs os)
(if (not (= (length stxs) (length tys)))
(tc-error/expr #:return (ret (map (lambda _ (Un)) stxs))

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -1352,7 +1352,7 @@
(make-PolyDots ns (method->function type))]
[(PolyRow-names: ns constraints body)
(make-PolyRow ns constraints (method->function type))]
[_ (tc-error/expr "expected a function type for method")]))
[_ (tc-error/expr #:return -Bottom "expected a function type for method")]))
;; annotate-method : Syntax Type -> Syntax
;; Adds a self type annotation for the first argument and annotated

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

@ -348,8 +348,7 @@
"function")])
(if (and (andmap null? msg-doms)
(null? argtypes))
(tc-error/expr #:return (ret (Un))
(string-append
(tc-error/expr (string-append
"Could not infer types for applying polymorphic "
fcn-string
"\n"))
@ -372,8 +371,7 @@
"function with keywords")])
(if (and (andmap null? msg-doms)
(null? argtypes))
(tc-error/expr #:return (ret (Un))
(string-append
(tc-error/expr (string-append
"Could not infer types for applying polymorphic "
fcn-string
"\n"))

9
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -36,14 +36,13 @@
#f])]))
(define (index-error i-val i-bound expr type name)
(define return (ret -Bottom))
(cond
[(not (and (integer? i-val) (exact? i-val)))
(tc-error/expr #:stx expr #:return return "expected exact integer for ~a index, but got ~a" name i-val)]
(tc-error/expr #:stx expr "expected exact integer for ~a index, but got ~a" name i-val)]
[(< i-val 0)
(tc-error/expr #:stx expr #:return return "index ~a too small for ~a ~a" i-val name type)]
(tc-error/expr #:stx expr "index ~a too small for ~a ~a" i-val name type)]
[(not (< i-val i-bound))
(tc-error/expr #:stx expr #:return return "index ~a too large for ~a ~a" i-val name type)]))
(tc-error/expr #:stx expr "index ~a too large for ~a ~a" i-val name type)]))
(define (valid-index? i bound)
(and (integer? i) (exact? i) (<= 0 i (sub1 bound))))
@ -119,7 +118,7 @@
(tc-expr/check/t e (ret t))))
-true-filter)]
[else
(tc-error/expr #:return (ret -Bottom)
(tc-error/expr
"expected vector with ~a elements, but got ~a"
(length ts) (make-HeterogeneousVector (stx-map tc-expr/t #'(args ...))))])]
;; If the expected type is a union, then we examine just the parts

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

@ -46,11 +46,9 @@
(tc-keywords #'(#%plain-app . form) arities (type->list (tc-expr/t #'kws))
#'kw-arg-list #'pos-args expected)]
[(tc-result1: (Poly: _ (Function: _)))
(tc-error/expr #:return (ret (Un))
"Inference for polymorphic keyword functions not supported")]
(tc-error/expr "Inference for polymorphic keyword functions not supported")]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)])))
(tc-error/expr "Cannot apply expression of type ~a, since it is not a function type" t)])))
(define (tc-keywords/internal arity kws kw-args error?)
(match arity
@ -64,15 +62,13 @@
(void)]
[(_ '())
(if error?
(tc-error/expr #:return (ret (Un))
"Unexpected keyword argument ~a" (car actual-kws))
(tc-error/delayed "Unexpected keyword argument ~a" (car actual-kws))
#f)]
[('() (cons fst rst))
(match fst
[(Keyword: k _ #t)
(if error?
(tc-error/expr #:return (ret (Un))
"Missing keyword argument ~a" k)
(tc-error/delayed "Missing keyword argument ~a" k)
#f)]
[_ (loop actual-kws actuals rst)])]
[((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))

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

@ -53,8 +53,7 @@
expected-elem-type))
[(tc-result1: t) (ret (make-ListDots t bound0))]
[(tc-results: ts)
(tc-error/expr #:return (ret (Un))
"Expected one value, but got ~a" (-values ts))])]
(tc-error/expr "Expected one value, but got ~a" (-values ts))])]
;; otherwise, if it's not a ListDots, defer to the regular function typechecking
;; TODO fix double typechecking
[(res0 res) (tc/app-regular #'form expected)]))

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -81,8 +81,7 @@
(check-named-inits other-inits given-names name-assoc)])
(ret (make-Instance c))]
[t
(tc-error/expr #:return (ret (Un))
"expected a class value for object creation, got: ~a" t)]))
(tc-error/expr "expected a class value for object creation, got: ~a" t)]))
(define (check-named-inits inits names name-assoc)
(define init-names (map car inits))
@ -112,8 +111,7 @@
(syntax-parse meth [(quote m:id) (syntax-e #'m)] [_ #f]))
(define obj-type (tc-expr/t obj))
(unless maybe-meth-sym
(tc-error/expr #:return (ret (Un))
"expected a symbolic method name, but got ~a" meth))
(tc-error/expr "expected a symbolic method name, but got ~a" meth))
(define (check obj-type)
(match (resolve obj-type)
;; FIXME: handle unions and mu?
@ -122,7 +120,6 @@
(λ (field-entry) (ret (cadr field-entry)))]
[else
(tc-error/expr/fields "type mismatch"
#:return (ret (Un))
#:more "the object is missing an expected field"
"field" maybe-meth-sym
"object type" ty)])]
@ -131,7 +128,6 @@
[type
(tc-error/expr/fields "type mismatch"
#:more "expected an object value for get-field"
#:return (ret (Un))
"given" type)]))
(check obj-type))
@ -141,8 +137,7 @@
(define maybe-field-sym
(syntax-parse field [(quote f:id) (syntax-e #'f)] [_ #f]))
(unless maybe-field-sym
(tc-error/expr #:return (ret (Un))
"expected a symbolic field name, but got ~a" field))
(tc-error/expr "expected a symbolic field name, but got ~a" field))
(define obj-type (tc-expr/t obj))
(define val-type (tc-expr/t val))
(define (check obj-type)
@ -163,14 +158,12 @@
(tc-error/expr/fields "type mismatch"
#:more (~a "expected an object with field "
maybe-field-sym)
#:return (ret (Un))
"given" ty)])]
[(Instance: (? needs-resolving? type))
(check (make-Instance (resolve type)))]
[type
(tc-error/expr/fields "type mismatch"
#:more "expected an object value for set-field!"
#:return (ret (Un))
"given" type)]))
(check obj-type))

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

@ -33,13 +33,13 @@
(single-value #'arg expected)]
[(tc-results: ts)
(single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr #:return (ret -Bottom)
(tc-error/expr
"wrong number of values: expected ~a but got one"
(length ts))]
;; match polydots case and error
[(tc-results: ts _ _ dty dbound)
(single-value #'arg)
(tc-error/expr #:return (ret -Bottom)
(tc-error/expr
"Expected ~a ..., but got only one value" dty)]))
;; handle `values' specially
(pattern (values . args)
@ -53,7 +53,7 @@
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (syntax-length #'args))
(ret ts fs os)
(tc-error/expr #:return (ret -Bottom) "wrong number of values: expected ~a but got ~a"
(tc-error/expr "wrong number of values: expected ~a but got ~a"
(length ets) (syntax-length #'args))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (in-syntax #'args)])

13
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -38,8 +38,7 @@
[(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))))
;; special case for (case-lambda)
(when (null? doms)
(tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply"))
(tc-error/expr "empty case-lambda given as argument to apply"))
(match-let* ([arg-tres (map tc-expr fixed-args)]
[arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)]
[(tc-result1: tail-ty) (single-value tail)])
@ -138,8 +137,7 @@
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (Poly: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
(tc-error/expr "Function has no cases")]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))
(let*-values ([(arg-tres) (map tc-expr fixed-args)]
@ -221,7 +219,6 @@
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (PolyDots: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result1: f-ty) (tc-error/expr #:return (ret (Un))
"Type of argument to apply is not a function type: \n~a" f-ty)]))
(tc-error/expr "Function has no cases")]
[(tc-result1: f-ty)
(tc-error/expr "Type of argument to apply is not a function type: \n~a" f-ty)]))

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

@ -126,7 +126,7 @@
(check-row-constraints
row constraints
(λ (name)
(tc-error/expr
(tc-error/delayed
(~a "Cannot instantiate row with member " name
" that the given row variable requires to be absent"))))
(instantiate-poly ty (list row))]))]
@ -210,10 +210,10 @@
(cond [(and (identifier? var) (lookup-type/lexical var #:fail (λ _ #f)))
=>
(λ (t)
(tc-error/expr #:return (ret (Un)) #:stx stx
(tc-error/expr #:stx stx
(string-append (syntax-e msg) "; missing coverage of ~a")
t))]
[else (tc-error/expr #:return (ret (Un)) #:stx stx (syntax-e msg))]))
[else (tc-error/expr #:stx stx (syntax-e msg))]))
;; check that `expr` doesn't evaluate any references
;; to `name` that aren't under `lambda`
@ -288,11 +288,10 @@
;(check-below key-t -Symbol)
;; FIXME -- would need to protect `e2` with any-wrap/c contract
;; instead, just fail
;(tc-expr/check/type #'e2 Univ)
;(tc-expr/check #'e3 expected)
(tc-error/expr "with-continuation-mark requires a continuation-mark-key, but got ~a" key-t
#:return (ret -Bottom))])]
(tc-error/expr "with-continuation-mark requires a continuation-mark-key, but got ~a" key-t)])]
;; application
[(#%plain-app . _) (tc/app/check form expected)]
;; #%expression
@ -355,7 +354,7 @@
[(tc-result1: t)
(with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))]
[(tc-results: ts)
(tc-error/expr #:return (ret (Un)) "Expected ~a values, but got only 1" (length ts))])]
(tc-error/expr "Expected ~a values, but got only 1" (length ts))])]
[(letrec-values ([(name ...) expr] ...) . body)
(tc/letrec-values #'((name ...) ...) #'(expr ...) #'body expected)]
;; other
@ -406,8 +405,7 @@
(tc-expr #'e3)]
[(tc-result1: key-t)
;; see comments in the /check variant
(tc-error/expr "with-continuation-mark requires a continuation-mark-key, but got ~a" key-t
#:return (ret (Un)))])]
(tc-error/expr "with-continuation-mark requires a continuation-mark-key, but got ~a" key-t)])]
;; lambda
[(#%plain-lambda formals . body)
(tc/lambda form #'(formals) #'(body))]
@ -519,8 +517,7 @@
[(tc-result1: _ _ _) t]
[_ (tc-error/expr
#:stx form
#:return (ret (Un))
"expected single value, got multiple (or zero) values")]))
"expected single value, got multiple (or zero) values")]))
;; type-check a body of exprs, producing the type of the last one.
;; if the body is empty, the type is Void.

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

@ -166,7 +166,6 @@
in t))]
[((tc-result1: (Param: _ _)) _)
(tc-error/expr
#:return (ret (Un))
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))]
;; resolve names, polymorphic apps, mu, etc
@ -182,12 +181,10 @@
;; otherwise fail
[((tc-result1: (and f-ty (Poly: ns (Function: arrs)))) _)
(tc-error/expr
#:return (ret (Un))
(string-append "Cannot infer type instantiation for type ~a. Please add "
"more type annotations")
f-ty)]
[((tc-result1: f-ty) _)
(tc-error/expr
#:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type"
f-ty)]))

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-if.rkt
View File

@ -99,6 +99,5 @@
(ret us fs3 os3)]
;; otherwise, error
[else
(tc-error/expr #:return (ret -Bottom)
"Expected the same number of values from both branches of `if' expression, but got ~a and ~a"
(tc-error/expr "Expected the same number of values from both branches of `if' expression, but got ~a and ~a"
(length ts) (length us))])])))]))

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

@ -22,15 +22,15 @@
(let* ([ftype (cond [(assq s methods) => cadr]
[else (tc-error/expr/fields "send: method not understood by object"
"method name" s
"object type" obj)])]
"object type" obj
#:return -Bottom)])]
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)])
(add-typeof-expr form retval)
retval)]
[(tc-result1: t) (int-err "non-symbol methods not supported by Typed Racket: ~a" t)])]
[(tc-result1: t) (tc-error/expr/fields
#:return (ret -Bottom)
"send: type mismatch"
"expected" "an object"
"given" t)]))
"send: type mismatch"
"expected" "an object"
"given" t)]))
(do-check (tc-expr rcvr)))

24
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt
View File

@ -3,6 +3,7 @@
(require "../utils/utils.rkt"
(rep type-rep)
(utils tc-utils)
(types tc-result)
"base-abbrev.rkt"
(prefix-in c: (contract-req))
racket/match)
@ -17,9 +18,9 @@
[lookup-type-fail (identifier? . c:-> . Type/c)]
[lookup-variance-fail (identifier? . c:-> . void?)])
;; produce a type-checking error, and also return a result (e.g., a type)
;; produce a type-checking error, and also return a result (e.g., a tc-result)
(define (tc-error/expr msg
#:return [return -Bottom]
#:return [return (ret -Bottom)]
#:stx [stx (current-orig-stx)]
. rest)
(apply tc-error/delayed #:stx stx msg rest)
@ -29,7 +30,7 @@
(define (tc-error/expr/fields msg
#:more [more #f]
#:stx [stx (current-orig-stx)]
#:return [return -Bottom]
#:return [return (ret -Bottom)]
. rst)
(apply tc-error/fields #:more more #:stx stx #:delayed? #t msg rst)
return)
@ -39,17 +40,20 @@
(match (identifier-binding e)
['lexical (tc-error/expr/fields "missing type for identifier"
#:more "consider adding a type annotation with `:'"
"identifier" (syntax-e e))]
"identifier" (syntax-e e)
#:return -Bottom)]
[#f (tc-error/expr/fields "missing type for top-level identifier"
#:more "either undefined or missing a type annotation"
"identifier" (syntax-e e))]
"identifier" (syntax-e e)
#:return -Bottom)]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(define-values (mod-path base-path)
(module-path-index-split nominal-source-mod))
(cond [(and (not mod-path) (not base-path))
(tc-error/expr/fields "missing type for identifier"
#:more "consider adding a type annotation with `:'"
"identifier" (syntax-e e))]
"identifier" (syntax-e e)
#:return -Bottom)]
[(equal? mod-path '(lib "typed/racket"))
(tc-error/expr/fields
"missing type for identifier"
@ -58,15 +62,17 @@
" to have a type for this identifier;"
" please file a bug report")
"identifier" (syntax-e e)
"from module" mod-path)]
"from module" mod-path
#:return -Bottom)]
[else
(tc-error/expr/fields "missing type for identifier"
#:more "consider using `require/typed' to import it"
"identifier" (syntax-e e)
"from module" mod-path)])]))
"from module" mod-path
#:return -Bottom)])]))
(define (lookup-type-fail i)
(tc-error/expr "~a is not bound as a type" (syntax-e i)))
(tc-error/expr #:return -Bottom "~a is not bound as a type" (syntax-e i)))
(define (lookup-variance-fail i)
(int-err "~a is bound but missing a variance" (syntax-e i)))