From 7dc5143f145c5bbb95f97d9ae7cee751b0f466ef Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 7 Jan 2014 16:02:10 -0500 Subject: [PATCH] Allow prefix function arrow type Also fix a regression that made arrow type parsing more permissive than desired due to missing colon^s --- .../typed-racket/private/parse-type.rkt | 21 ++++++++++++------- .../unit-tests/parse-type-tests.rkt | 21 +++++++++++++++++++ 2 files changed, 35 insertions(+), 7 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index e5749275e9..118395534f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -313,24 +313,29 @@ (list (make-arr doms (parse-type (syntax/loc stx (rest-dom ...)))))))] - [(dom :->^ rng : latent:simple-latent-filter) + [(~or (:->^ dom rng :colon^ latent:simple-latent-filter) + (dom :->^ rng :colon^ latent:simple-latent-filter)) ;; 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) 0 (attribute latent.path))] - [(dom ... :->^ rng - : ~! (~var latent (full-latent (syntax->list #'(dom ...))))) + [(~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))] - [(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)) (make-Function (list (make-arr (parse-types #'(dom ...)) (parse-values-type #'rng) #:rest (parse-type #'rest) #:kws (attribute kws.Keyword))))] - [(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)) (let* ([bnd (syntax-e #'bound)]) (unless (bound-index? bnd) (tc-error/stx #'bound @@ -343,7 +348,8 @@ (extend-tvars (list bnd) (parse-type #'rest)) bnd))))] - [(dom:non-keyword-ty ... rest:non-keyword-ty _:ddd :->^ rng) + [(~or (:->^ dom:non-keyword-ty ... rest:non-keyword-ty _:ddd rng) + (dom:non-keyword-ty ... rest:non-keyword-ty _:ddd :->^ rng)) (let ([var (infer-index stx)]) (make-Function (list @@ -356,7 +362,8 @@ (->* (parse-types #'(dom ...)) (parse-values-type #'rng))] |# ;; use expr to rule out keywords - [(dom:non-keyword-ty ... kws:keyword-tys ... :->^ rng) + [(~or (:->^ dom:non-keyword-ty ... kws:keyword-tys ... rng) + (dom:non-keyword-ty ... kws:keyword-tys ... :->^ rng)) (let ([doms (for/list ([d (in-syntax #'(dom ...))]) (parse-type d))]) (make-Function diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt index fdc981ec55..f57cbd49f9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt @@ -82,30 +82,42 @@ [(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))] [(Number -> Number) (t:-> N N)] [(All (A) Number -> Number) (-poly (a) (t:-> N N))] + [(All (A) -> Number Number) (-poly (a) (t:-> N N))] [(All (A) (Number -> Number)) (-poly (a) (t:-> N N))] + [(All (A) (-> Number Number)) (-poly (a) (t:-> N N))] [(All (A) A -> A) (-poly (a) (t:-> a a))] [(All (A) A → A) (-poly (a) (t:-> a a))] + [(All (A) → A A) (-poly (a) (t:-> a a))] [(All (A) (A -> A)) (-poly (a) (t:-> a a))] + [(All (A) (-> A A)) (-poly (a) (t:-> a a))] ;; requires transformer time stuff that doesn't work #;[(Refinement even?) (make-Refinement #'even?)] [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] + [(-> Number Number Number Boolean Number) (N N N B . t:-> . N)] [(Number Number Number * -> Boolean) ((list N N) N . t:->* . B)] + [(-> Number Number Number * Boolean) ((list N N) N . t:->* . B)] ;[((. Number) -> Number) (->* (list) N N)] ;; not legal syntax [(U Number Boolean) (t:Un N B)] [(U Number Boolean Number) (t:Un N B)] [(U Number Boolean 1) (t:Un N B)] [(All (a) (Listof a)) (-poly (a) (make-Listof a))] [(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] + [(All (a ...) (-> a ... a Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a) (Listof a)) (-poly (a) (make-Listof a))] [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] + [(∀ (a ...) (-> a ... a Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(All (a ...) (a ... -> Number)) (-polydots (a) ((list) [a a] . ->... . N))] + [(All (a ...) (-> a ... Number)) + (-polydots (a) ((list) [a a] . ->... . N))] [(All (a ...) (-> (values a ...))) (-polydots (a) (t:-> (make-ValuesDots (list) a 'a)))] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] [(case-> (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] + [(case-> (Number -> Boolean) (-> Number Number Number)) (cl-> [(N) B] + [(N N) N])] [1 (-val 1)] [#t (-val #t)] [#f (-val #f)] @@ -117,14 +129,23 @@ [a (-v a) (dict-set initial-tvar-env 'a (-v a))] [(Any -> Boolean : Number) (make-pred-ty -Number)] + [(-> Any Boolean : Number) (make-pred-ty -Number)] [(Any -> Boolean : #:+ (Number @ 0) #:- (! Number @ 0)) (make-pred-ty -Number)] + [(-> Any Boolean : #:+ (Number @ 0) #:- (! Number @ 0)) + (make-pred-ty -Number)] [(Any -> Boolean : #:+ (! Number @ 0) #:- (Number @ 0)) (t:->* (list Univ) -Boolean : (-FS (-not-filter -Number 0 null) (-filter -Number 0 null)))] + [(-> Any Boolean : #:+ (! Number @ 0) #:- (Number @ 0)) + (t:->* (list Univ) -Boolean : (-FS (-not-filter -Number 0 null) (-filter -Number 0 null)))] [(Number -> Number -> Number) (t:-> -Number (t:-> -Number -Number))] + [(-> Number (-> Number Number)) + (t:-> -Number (t:-> -Number -Number))] [(Integer -> (All (X) (X -> X))) (t:-> -Integer (-poly (x) (t:-> x x)))] + [(-> Integer (All (X) (-> X X))) + (t:-> -Integer (-poly (x) (t:-> x x)))] [(Opaque foo?) (make-Opaque #'foo?)] ;; PR 14122