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

Make error messages better for function types with bad filters.

Browse Source 
Also makes it so filters are not parsed as keyword types.

Closes PR 14492.
Closes PR 14520.
This commit is contained in:
Eric Dobson 2014-07-06 22:35:23 -07:00
parent fdd7679426
commit 0142549750
2 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,6 +14,7 @@
lexical-env index-env row-constraint-env) lexical-env index-env row-constraint-env)
(only-in racket/list flatten) (only-in racket/list flatten)
racket/dict racket/dict
racket/promise
racket/format racket/format
racket/match racket/match
racket/syntax racket/syntax
@ -162,21 +163,19 @@
;; optional or mandatory depending on where it's used ;; optional or mandatory depending on where it's used
(define-splicing-syntax-class plain-kw-tys (define-splicing-syntax-class plain-kw-tys
(pattern (~seq k:keyword t:expr) (pattern (~seq k:keyword t:expr)
#:attr mand-kw (make-Keyword (syntax-e #'k) (parse-type #'t) #t) #:attr mand-kw (delay (make-Keyword (syntax-e #'k) (parse-type #'t) #t))
#:attr opt-kw (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) #:attr opt-kw (delay (make-Keyword (syntax-e #'k) (parse-type #'t) #f))))
(define-splicing-syntax-class keyword-tys (define-splicing-syntax-class keyword-tys
(pattern kw:plain-kw-tys #:attr Keyword (attribute kw.mand-kw)) (pattern kw:plain-kw-tys #:attr Keyword (attribute kw.mand-kw))
;; custom optional keyword syntax for TR ;; custom optional keyword syntax for TR
(pattern (~seq [k:keyword t:expr]) (pattern (~seq [k:keyword t:expr])
#:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) #:attr Keyword (delay (make-Keyword (syntax-e #'k) (parse-type #'t) #f))))
(define-syntax-class non-keyword-ty (define-syntax-class non-keyword-ty
(pattern (k e ...) (pattern (k:expr e ...))
#:when (not (keyword? (syntax->datum #'k)))) (pattern (~and t:expr (~not :colon^) (~not :->^))
(pattern t:expr #:when (not (syntax->list #'t))))
#:when (and (not (keyword? (syntax->datum #'t)))
(not (syntax->list #'t)))))
;; syntax classes for parsing ->* function types ;; syntax classes for parsing ->* function types
(define-syntax-class ->*-mand (define-syntax-class ->*-mand
@ -416,15 +415,6 @@
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type) (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type)
(-acc-path (attribute latent.path) (-arg-path 0)))] (-acc-path (attribute latent.path) (-arg-path 0)))]
[(~or (:->^ dom ... rng
:colon^ ~! (~var latent (full-latent (syntax->list #'(dom ...)))))
(dom ... :->^ rng
:colon^ ~! (~var latent (full-latent (syntax->list #'(dom ...))))))
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(->* (parse-types #'(dom ...))
(parse-type #'rng)
: (-FS (attribute latent.positive) (attribute latent.negative))
: (attribute latent.object))]
[(~or (:->^ dom:non-keyword-ty ... kws:keyword-tys ... rest:non-keyword-ty ddd:star rng) [(~or (:->^ dom:non-keyword-ty ... kws:keyword-tys ... rest:non-keyword-ty ddd:star rng)
(dom:non-keyword-ty ... kws:keyword-tys ... rest:non-keyword-ty ddd:star :->^ rng)) (dom:non-keyword-ty ... kws:keyword-tys ... rest:non-keyword-ty ddd:star :->^ rng))
(make-Function (make-Function
@ -432,7 +422,7 @@
(parse-types #'(dom ...)) (parse-types #'(dom ...))
(parse-values-type #'rng) (parse-values-type #'rng)
#:rest (parse-type #'rest) #:rest (parse-type #'rest)
#:kws (attribute kws.Keyword))))] #:kws (map force (attribute kws.Keyword)))))]
[(~or (:->^ dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound rng) [(~or (:->^ dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound rng)
(dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound :->^ rng)) (dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound :->^ rng))
(let* ([bnd (syntax-e #'bound)]) (let* ([bnd (syntax-e #'bound)])
@ -470,7 +460,17 @@
(list (make-arr (list (make-arr
doms doms
(parse-values-type #'rng) (parse-values-type #'rng)
#:kws (attribute kws.Keyword)))))] #:kws (map force (attribute kws.Keyword))))))]
;; This case needs to be at the end because it uses cut points to give good error messages.
[(~or (:->^ ~! dom:non-keyword-ty ... rng:expr
:colon^ (~var latent (full-latent (syntax->list #'(dom ...)))))
(dom:non-keyword-ty ... :->^ rng:expr
~! :colon^ (~var latent (full-latent (syntax->list #'(dom ...))))))
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(->* (parse-types #'(dom ...))
(parse-type #'rng)
: (-FS (attribute latent.positive) (attribute latent.negative))
: (attribute latent.object))]
[(:->*^ mand:->*-mand opt:->*-opt rest:->*-rest rng) [(:->*^ mand:->*-mand opt:->*-opt rest:->*-rest rng)
(define doms (for/list ([d (attribute mand.doms)]) (define doms (for/list ([d (attribute mand.doms)])
(parse-type d))) (parse-type d)))
@ -479,8 +479,8 @@
(opt-fn doms opt-doms (parse-values-type #'rng) (opt-fn doms opt-doms (parse-values-type #'rng)
#:rest (and (attribute rest.type) #:rest (and (attribute rest.type)
(parse-type (attribute rest.type))) (parse-type (attribute rest.type)))
#:kws (append (attribute mand.kws) #:kws (map force (append (attribute mand.kws)
(attribute opt.kws)))] (attribute opt.kws))))]
[:->^ [:->^
(parse-error #:delayed? #t "incorrect use of -> type constructor") (parse-error #:delayed? #t "incorrect use of -> type constructor")
Err] Err]

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

@ -176,6 +176,8 @@
[(-> 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"] [FAIL -> #:msg "incorrect use of -> type constructor"]
[FAIL (Any -> Any #:object 0) #:msg "expected the identifier `:'"]
[FAIL (-> Any Any #:+ (String @ x)) #:msg "expected the identifier `:'"]
[(Any -> Boolean : #:+ (Symbol @ not-mutated-var)) [(Any -> Boolean : #:+ (Symbol @ not-mutated-var))