diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt index 67ae08d39..b9b8a4e41 100644 --- a/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -364,7 +364,7 @@ ;; Most Top types are in the predefined table, the ones here ;; are not [(StructTop: name) `(make-StructTop ,(type->sexp name))] - [(TypeConstructor constr arity kind*? productive?) + [(TypeConstructor arity kind*? productive? constr) (define constr^ (gen-serialize-type-rep constr type->sexp)) `(make-type-constr ,constr^ ,arity ,productive? #:kind*? ,kind*?)])) @@ -489,7 +489,7 @@ kind-env-map (lambda (id v) ;; TODO: turn this into a function - (match-define (TypeConstructor constr arity kind*? productive?) v) + (match-define (TypeConstructor arity kind*? productive? constr) v) (define constr^ (gen-serialize-type-rep constr type->sexp)) #`(register-type-constructor! #'#,id (make-type-constr #,constr^ #,arity #,productive? #:kind*? #,kind*?))))) diff --git a/typed-racket-lib/typed-racket/private/parse-type.rkt b/typed-racket-lib/typed-racket/private/parse-type.rkt index 648a383a2..0a19b6d1a 100644 --- a/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -69,7 +69,7 @@ (values (c:listof identifier?) (c:listof identifier?) boolean?))] - [parse-type-or-type-constructor (syntax? . c:-> . (c:or/c Type? TypeConstructor?))] + [parse-type-or-type-constructor (syntax? . c:-> . (c:or/c Type? TypeConstructor? TypeConstructorStub?))] ;; Parse the given identifier using the lexical ;; context of the given syntax object [parse-type/id (syntax? c:any/c . c:-> . Type?)] @@ -118,6 +118,16 @@ e ...)) +(define type-constr-stub-tbl (make-hash)) + +(define (get-type-constr-stub id) + (hash-ref type-constr-stub-tbl (syntax->datum id) #f)) + +(define-syntax-rule (define-literal-type-constr-stub id arity kind* productive?) + (begin + (define-literal-syntax-class #:for-label id) + (hash-set! type-constr-stub-tbl (quote id) (TypeConstructorStub arity kind* productive?)))) + (define-literal-syntax-class #:for-label car) (define-literal-syntax-class #:for-label cdr) (define-literal-syntax-class #:for-label vector-length) @@ -133,8 +143,8 @@ (define-literal-syntax-class #:for-label init-depend) (define-literal-syntax-class #:for-label Refinement) (define-literal-syntax-class #:for-label Instance) -(define-literal-syntax-class #:for-label List) -(define-literal-syntax-class #:for-label List*) +(define-literal-type-constr-stub List 0 #t #t) +(define-literal-type-constr-stub List* 1 #t #t) (define-literal-syntax-class #:for-label pred) (define-literal-syntax-class #:for-label ->) (define-literal-syntax-class #:for-label ->*) @@ -860,14 +870,12 @@ (if res (parse-values-type res do-parse do-parse-multi) (-values (list -Void))))] [(:List^ ts ...) (parse-list-type stx - (lambda (stx) - (do-parse stx (add1 current-level))) - (lambda (stx-li) - (do-parse-multi stx-li (add1 current-level))))] + do-parse + do-parse-multi)] [(:List*^ ts ... t) - (-Tuple* (do-parse-multi #'(ts ...) (add1 current-level)) (do-parse #'t (add1 current-level)))] + (-Tuple* (do-parse-multi #'(ts ...)) (do-parse #'t))] [(:cons^ fst rst) - (-pair (do-parse #'fst (add1 current-level)) (do-parse #'rst (add1 current-level)))] + (-pair (do-parse #'fst) (do-parse #'rst))] [(:pred^ t) (make-pred-ty (do-parse #'t))] [((~and :case->^ operator) tys ...) @@ -1257,6 +1265,9 @@ [(bound-index? v) (parse-error "type variable must be used with ..." "variable" v)] + [(and ret-type-op? (get-type-constr-stub #'id)) + => (lambda (t) + t)] ;; if it's a type alias, we expand it (the expanded type is stored in the HT) [(lookup-type-alias #'id do-parse (lambda () #f)) => @@ -1299,7 +1310,7 @@ #:ret-type-op? #t)) (define args^ (let ([lvl (match rator - [(struct* TypeConstructor ([productive? #t])) + [(and (? TypeConstructor?) (? type-constr-productive?)) (add1 current-level)] ;; when checking user-defined type constructors, structure types ;; defined in the enclosing module have not been registerd yet, so we diff --git a/typed-racket-lib/typed-racket/rep/type-constr.rkt b/typed-racket-lib/typed-racket/rep/type-constr.rkt index 714776d99..49315342c 100644 --- a/typed-racket-lib/typed-racket/rep/type-constr.rkt +++ b/typed-racket-lib/typed-racket/rep/type-constr.rkt @@ -7,7 +7,10 @@ (provide print-kind make-type-constr + type-constr-productive? + type-constr-arity (struct-out TypeConstructor) + (struct-out TypeConstructorStub) (struct-out exn:fail:contract:arity:type-constructor)) (define-values (prop:kind kind? kind-acc) (make-struct-type-property 'kind)) @@ -31,16 +34,24 @@ [gen-serialize-type-rep type-rep-maker ty->sexp]) +(struct TypeConstructorBase (arity kind*? productive?) #:transparent) + +(define (type-constr-productive? ty-op) + (TypeConstructorBase-productive? ty-op)) + +(define (type-constr-arity ty-op) + (TypeConstructorBase-arity ty-op)) + ;; real-trep-constr: the underlying *named* type rep constructor ;; arity: the mandatory arity ;; kind*: whether this type constructor can take an arbitrary number of arguments ;; productive?: whether this type constructor is productive. -(struct TypeConstructor (real-trep-constr arity kind*? productive?) +(struct TypeConstructor TypeConstructorBase (real-trep-constr) #:transparent #:property prop:kind #t #:property prop:procedure (lambda (me . args) - (match-define (TypeConstructor real-trep-constr arity kind*? _) me) + (match-define (TypeConstructor arity kind*? _ real-trep-constr) me) ;; FIXME: real-trep-constr can take other arguments than types. ;; This could make handling k* more complicated. ;; naive assumpution: type arguments come first in args. @@ -65,14 +76,16 @@ (if (and (zero? arity) (not kind*?)) type-maker - (TypeConstructor type-maker arity kind*? productive))) + (TypeConstructor arity kind*? productive type-maker))) + +(struct TypeConstructorStub TypeConstructorBase [] #:transparent) (define (print-kind type-or-type-op) (match type-or-type-op - [(struct* TypeConstructor ([arity arity] - [kind*? kind*?] - [productive? productive?])) + [(struct* TypeConstructorBase ([arity arity] + [kind*? kind*?] + [productive? productive?])) (define mandatory-stars (make-list arity "*")) (define all-stars (if kind*? (append mandatory-stars (list "* ...")) mandatory-stars)) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index b8f8b93c3..66934f154 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -573,7 +573,8 @@ (define tvars (map syntax-e vars)) (define new-tvars (map make-F tvars)) (define parent (match parent^ - [(struct* TypeConstructor ([arity expected])) + [(? TypeConstructor?) + (define expected (type-constr-arity parent^)) (define given (length new-tvars)) (unless (<= expected given) (tc-error (~a "wrong number of arguments to type constructor" diff --git a/typed-racket-test/unit-tests/interactive-tests.rkt b/typed-racket-test/unit-tests/interactive-tests.rkt index dd542c8ae..a18641f7c 100644 --- a/typed-racket-test/unit-tests/interactive-tests.rkt +++ b/typed-racket-test/unit-tests/interactive-tests.rkt @@ -195,6 +195,15 @@ (test-form (regexp-quote "(-> * *)") (:kind MListof)) (test-form (regexp-quote "(-> * *)") (:kind Thread-Cellof)) (test-form (regexp-quote "(-> * *)") (:kind Weak-Boxof)) + (test-form (regexp-quote "(-> * * ... *)") (:kind List*)) + (test-form (regexp-quote "(-> * ... *)") (:kind List)) + (test-form #rx"^$" + (begin + (define-type MyList List) + (define-type MyList* List*))) + (test-form (regexp-quote "(-> * ... *)") (:kind MyList)) + (test-form (regexp-quote "(-> * * ... *)") (:kind MyList*)) + (test-form (regexp-quote "(-> * *)") (:kind Vectorof)) (test-form-not-exn (define-type (Bar a) a)) (test-form (regexp-quote "(-o * *)")