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

Make parse-type raise the right error for incorrect use of ->.

Browse Source
This commit is contained in:
Eric Dobson 2014-07-06 20:53:55 -07:00
parent eb8c2d33b1
commit 75310338dc
2 changed files with 21 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -479,6 +479,9 @@
(parse-type (attribute rest.type))) (parse-type (attribute rest.type)))
#:kws (append (attribute mand.kws) #:kws (append (attribute mand.kws)
(attribute opt.kws)))] (attribute opt.kws)))]
[:->^
(parse-error #:delayed? #t "incorrect use of -> type constructor")
Err]
[id:identifier [id:identifier
(cond (cond
;; if it's a type variable, we just produce the corresponding reference (which is in the HT) ;; if it's a type variable, we just produce the corresponding reference (which is in the HT)
@ -498,9 +501,6 @@
(set-box! alias-box (cons #'id (unbox alias-box)))) (set-box! alias-box (cons #'id (unbox alias-box))))
(add-disappeared-use (syntax-local-introduce #'id)) (add-disappeared-use (syntax-local-introduce #'id))
t)] t)]
[(free-identifier=? #'id #'->)
(parse-error #:delayed? #t "incorrect use of -> type constructor")
Err]
[else [else
(parse-error #:delayed? #t (~a "type name `" (syntax-e #'id) "' is unbound")) (parse-error #:delayed? #t (~a "type name `" (syntax-e #'id) "' is unbound"))
Err])] Err])]

28
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

@ -5,6 +5,7 @@
racket/base racket/base
racket/dict racket/dict
racket/set racket/set
syntax/parse
(base-env base-structs) (base-env base-structs)
(env tvar-env type-alias-env) (env tvar-env type-alias-env)
(utils tc-utils) (utils tc-utils)
@ -29,22 +30,28 @@
(do-standard-inits)) (do-standard-inits))
(define-syntax (pt-test stx) (define-syntax (pt-test stx)
(syntax-case stx (FAIL) (syntax-parse stx
[(_ FAIL ty-stx) [(_ (~datum FAIL) ty-stx:expr
(syntax/loc stx (pt-test FAIL ty-stx initial-tvar-env))] (~optional tvar-env:expr #:defaults [(tvar-env #'initial-tvar-env)])
[(_ FAIL ty-stx tvar-env) (~optional (~seq #:msg msg*:expr) #:defaults [(msg* #'#f)]))
(quasisyntax/loc stx (quasisyntax/loc stx
(test-case #,(format "~a" (syntax->datum #'ty-stx)) (test-case #,(format "~a" (syntax->datum #'ty-stx))
(unless (define msg msg*)
(define actual-message
(phase1-phase0-eval (phase1-phase0-eval
(with-handlers ([exn:fail:syntax? (lambda (exn) #'#t)]) (with-handlers ([exn:fail:syntax? (lambda (exn) #`#,(exn-message exn))])
(parameterize ([current-tvars tvar-env] (parameterize ([current-tvars tvar-env]
[delay-errors? #f]) [delay-errors? #f])
(parse-type (quote-syntax ty-stx))) (parse-type (quote-syntax ty-stx)))
#'#f)) #'#f)))
(fail-check "No syntax error when parsing type."))))] (unless actual-message
[(_ ts tv) (syntax/loc stx (pt-test ts tv initial-tvar-env))] (fail-check "No syntax error when parsing type."))
[(_ ty-stx ty-val tvar-env) (when msg
(unless (regexp-match? msg actual-message)
(with-check-info (['expected msg] ['actual actual-message])
(fail-check "parse-type raised the wrong error message"))))))]
[(_ ty-stx:expr ty-val:expr
(~optional tvar-env:expr #:defaults [(tvar-env #'initial-tvar-env)]))
(quasisyntax/loc (quasisyntax/loc
stx stx
(test-case #,(format "~a" (syntax->datum #'ty-stx)) (test-case #,(format "~a" (syntax->datum #'ty-stx))
@ -163,6 +170,7 @@
(t:-> -Integer (-poly (x) (t:-> x x)))] (t:-> -Integer (-poly (x) (t:-> x x)))]
[(-> Integer (All (X) (-> X X))) [(-> Integer (All (X) (-> X X)))
(t:-> -Integer (-poly (x) (t:-> x x)))] (t:-> -Integer (-poly (x) (t:-> x x)))]
[FAIL -> #:msg "incorrect use of -> type constructor"]
;; ->* types ;; ->* types
[(->* (String Symbol) Void) (t:-> -String -Symbol -Void)] [(->* (String Symbol) Void) (t:-> -String -Symbol -Void)]