diff --git a/collects/tests/typed-racket/succeed/structs-variance2.rkt b/collects/tests/typed-racket/succeed/structs-variance2.rkt new file mode 100644 index 0000000000..55b1d5351c --- /dev/null +++ b/collects/tests/typed-racket/succeed/structs-variance2.rkt @@ -0,0 +1,7 @@ +#lang typed/racket + +(struct: (a) foo ((v : ((baz a) -> Symbol)))) +(struct: (a) bar ((v : ((foo a) -> Symbol)))) +(struct: (a) baz ((v : ((bar a) -> Symbol)))) + +(ann (ann (foo (lambda (x) 'x)) (foo String)) (foo Symbol)) diff --git a/collects/typed-racket/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt index ce91a0fc3c..01f9e9e282 100644 --- a/collects/typed-racket/typecheck/tc-structs.rkt +++ b/collects/typed-racket/typecheck/tc-structs.rkt @@ -231,7 +231,7 @@ (define (refine-struct-variance! parsed-structs) (define stys (map parsed-struct-sty parsed-structs)) - (define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs)) + (define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs)) (let loop () (define sames (for/list ((sty stys) (tvars tvarss)) diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index ca655a9401..5e1c87a047 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -74,19 +74,20 @@ [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)]))) -(define (add-constant-variance! form) +(define (type-vars-of-struct form) (parameterize ([current-orig-stx form]) (syntax-parse form #:literals (values define-typed-struct-internal quote-syntax #%plain-app) ;; define-typed-struct [(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values))) - ;; TODO make constant - (unless (null? (attribute dts.tvars)) - (register-type-variance! #'dts.name (map (lambda (_) Covariant) (attribute dts.tvars))))] + (attribute dts.tvars)] [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) ;; Not polymorphic - (void)]))) + null]))) +(define (add-constant-variance! name vars) + (unless (null? vars) + (register-type-variance! name (map (lambda (_) Constant) vars)))) @@ -305,8 +306,10 @@ (for-each (compose register-type-alias parse-type-alias) type-aliases) ;; Add the struct names to the type table, but not with a type ;(printf "before adding type names~n") - (for-each (compose register-type-name name-of-struct) struct-defs) - (for-each add-constant-variance! struct-defs) + (let ((names (map name-of-struct struct-defs)) + (type-vars (map type-vars-of-struct struct-defs))) + (for-each register-type-name names) + (for-each add-constant-variance! names type-vars)) ;(printf "after adding type names~n") ;; resolve all the type aliases, and error if there are cycles (resolve-type-aliases parse-type)