From 85f997b4c76007d596c5285a28e159a87bf09b22 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 20 Oct 2012 13:38:10 -0700 Subject: [PATCH] Make struct: form have the correct bindings in struct info. Also fixes reexport of struct-type to typed modules. Reexport issue. Closes PR13160. Constructor issue. Closes PR13161. Struct copy issues. Closes PR 10765. Closes PR 12513. Closes PR 13149. original commit: 9586dca0a339560d12777d22b624e6c9bd3f52e7 --- .../typed-racket/base-env/prims.rkt | 10 ++-- .../typed-racket/env/lexical-env.rkt | 7 +++ .../typed-racket/typecheck/def-binding.rkt | 6 +- .../typecheck/provide-handling.rkt | 59 +++++++++++++------ .../typed-racket/typecheck/renamer.rkt | 15 ++++- .../typed-racket/typecheck/tc-structs.rkt | 46 ++++++++------- .../typed-racket/typecheck/tc-toplevel.rkt | 14 ++++- .../tests/typed-racket/succeed/pr10765.rkt | 17 ++++++ .../tests/typed-racket/succeed/pr13160.rkt | 14 +++++ .../tests/typed-racket/succeed/pr13161.rkt | 10 ++++ .../succeed/structs-across-modules.rkt | 16 +++++ 11 files changed, 163 insertions(+), 51 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr10765.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13160.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13161.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/structs-across-modules.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 158d38cc..0ea11258 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -60,6 +60,7 @@ This file defines two sorts of primitives. All of them are provided into any mod racket/lazy-require syntax/parse syntax/stx + racket/list racket/syntax unstable/sequence unstable/syntax @@ -604,12 +605,14 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) opts:struct-options) - (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]) + (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] + [cname (second (build-struct-names #'nm.name empty #t #t))]) (with-syntax ([d-s (ignore-some-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) #t)] [dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm (fs ...) + #:maker #,cname #,@mutable?))]) (if (eq? (syntax-local-context) 'top-level) ;; Use `eval` at top-level to avoid an unbound id error @@ -632,17 +635,14 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) opts:struct-options) - (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] - [cname (datum->syntax #f (format-symbol "make-~a" (syntax-e #'nm.name)))]) + (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]) (with-syntax ([d-s (ignore-property (quasisyntax/loc stx (struct #,@(attribute nm.new-spec) (fs.fld ...) - #:extra-constructor-name #,cname . opts)) #t)] [dtsi (quasisyntax/loc stx (dtsi* (vars.vars ...) nm.old-spec (fs ...) - #:maker #,cname #,@mutable?))]) ;; see comment above (if (eq? (syntax-local-context) 'top-level) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt index 25a38a66..f12a2901 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/lexical-env.rkt @@ -14,6 +14,7 @@ (env type-env-structs global-env mvar-env) (utils tc-utils) (only-in (rep type-rep) Type/c) + (typecheck renamer) (except-in (types utils abbrev kw-types) -> ->* one-of/c)) (provide lexical-env with-lexical-env with-lexical-env/extend @@ -41,6 +42,12 @@ (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) (lookup env i (λ (i) (lookup-type i (λ () (cond + [(syntax-property i 'constructor-for) + => (λ (prop) + (define orig (un-rename prop)) + (define t (lookup-type/lexical orig env)) + (register-type i t) + t)] [(syntax-procedure-alias-property i) => (λ (prop) (define orig (car (flatten prop))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-binding.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-binding.rkt index 5c063475..7c0554e1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-binding.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/def-binding.rkt @@ -5,10 +5,12 @@ (define-struct binding (name) #:transparent) (define-struct (def-binding binding) (ty) #:transparent) (define-struct (def-stx-binding binding) () #:transparent) -(define-struct (def-struct-stx-binding def-stx-binding) (static-info) #:transparent) +(define-struct (def-struct-stx-binding def-stx-binding) (static-info constructor-type) #:transparent) (provide/cond-contract (struct binding ([name identifier?])) (struct (def-binding binding) ([name identifier?] [ty any/c])) (struct (def-stx-binding binding) ([name identifier?])) - (struct (def-struct-stx-binding binding) ([name identifier?] [static-info (or/c #f struct-info?)]))) + (struct (def-struct-stx-binding binding) ([name identifier?] + [static-info (or/c #f struct-info?)] + [constructor-type any/c]))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 0283bccd..a111adf8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -30,6 +30,12 @@ ;; defs: defines in this module ;; provs: provides in this module ;; pos-blame-id: a #%variable-reference for the module + +;; The first returned value is a syntax object of definitions that defines the +;; contracted versions of the provided identifiers, and the corresponding +;; provides. +;; +;; The second value is a list of two element lists, which are type name aliases. (define (generate-prov defs provs pos-blame-id) ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key (define mapping (make-free-id-table)) @@ -59,42 +65,55 @@ [(dict-ref defs internal-id #f) => (match-lambda - [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f))) cnt)) - (mk-value-triple internal-id new-id cnt)] - [(def-struct-stx-binding _ (? struct-info? si)) - (mk-struct-syntax-triple internal-id new-id si)] + [(def-binding _ ty) + (mk-value-triple internal-id new-id ty)] + [(def-struct-stx-binding _ (? struct-info? si) constr-type) + (mk-struct-syntax-triple internal-id new-id si constr-type)] [(def-stx-binding _) (mk-syntax-triple internal-id new-id)])] ;; otherwise, not defined in this module, not our problem [else (values #'(begin) internal-id null)])) - ;; mk-struct-syntax-triple : identifier? identifier? struct-info? -> triple/c - (define (mk-struct-syntax-triple internal-id new-id si) + ;; mk-struct-syntax-triple : identifier? identifier? struct-info? Type/c -> triple/c + (define (mk-struct-syntax-triple internal-id new-id si constr-type) (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same) (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)) - (define-values (defns new-ids aliases) - (map/values 3 + (define-values (defns new-ids aliases) + (map/values 3 (lambda (e) (if (identifier? e) (mk e) (values #'(begin) e null))) - (list* type-desc constr pred super accs))) - (define/with-syntax (type-desc* constr* pred* super* accs* ...) - (for/list ([i (in-list new-ids)]) (if (identifier? i) #`(syntax #,i) i))) + (list* type-desc pred super accs))) + (define-values (constr-defn constr-new-id constr-aliases) + (cond + [(not (identifier? constr)) + (values #'(begin) #f null)] + [(free-identifier=? constr internal-id) + (mk-value-triple constr (generate-temporary constr) constr-type)] + [else + (mk constr)])) + + (define/with-syntax (constr* type-desc* pred* super* accs* ...) + (for/list ([i (in-list (cons constr-new-id new-ids))]) + (and (identifier? i) #`(quote-syntax #,i)))) + (with-syntax* ([id internal-id] [export-id new-id] - [untyped-id (freshen-id #'id)]) + [protected-id (freshen-id #'id)]) (values #`(begin + #,constr-defn #,@defns - (define-syntax untyped-id - (let ((info (list type-desc* constr* pred* (list accs* ...) + (define-syntax protected-id + (let ((info (list type-desc* (syntax export-id) pred* (list accs* ...) (list #,@(map (lambda (x) #'#f) accs)) super*))) #,(if type-is-constructor? #'(make-struct-info-self-ctor constr* info) #'info))) - (def-export export-id id untyped-id)) + (def-export export-id protected-id protected-id)) new-id - (cons (list #'export-id internal-id) (apply append aliases))))) + (cons (list #'export-id internal-id) + (apply append constr-aliases aliases))))) ;; mk-syntax-triple : identifier? identifier? -> triple/c @@ -112,16 +131,18 @@ (list (list #'export-id #'id))))) ;; mk-value-triple : identifier? identifier? (or/c syntax? #f) -> triple/c - (define (mk-value-triple internal-id new-id cnt) + (define (mk-value-triple internal-id new-id ty) + (define contract (type->contract ty (λ () #f))) + (with-syntax* ([id internal-id] [untyped-id (freshen-id #'id)] [export-id new-id]) (define/with-syntax definitions - (if cnt + (if contract (with-syntax* ([module-source pos-blame-id] [the-contract (generate-temporary 'generated-contract)]) #`(begin - (define the-contract #,cnt) + (define the-contract #,contract) (define-syntax untyped-id (make-provide/contract-transformer (quote-syntax the-contract) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/renamer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/renamer.rkt index 58c6863b..110f677f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/renamer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/renamer.rkt @@ -1,6 +1,6 @@ #lang racket/base -(provide renamer get-alternate) +(provide renamer get-alternate un-rename) ;; target : identifier ;; alternate : identifier @@ -21,3 +21,16 @@ (if alt (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) + +;; Undo renaming for type lookup. +;; Used because of macros that mark the identifier used as the binding such as +;; kw-application or struct constructors +;; +;; The syntax-transforming check is for unit tests +(define (un-rename id) + (if (syntax-transforming?) + (let-values (((binding new-id) (syntax-local-value/immediate id (lambda () (values #f #f))))) + (if (typed-renaming? binding) + new-id + id)) + id)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index c2e3b4fa..679082b3 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -95,10 +95,10 @@ (if (null? l) (values (reverse getters) (reverse setters)) (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters))))) - (match (build-struct-names nm flds #f #f nm) + (match (build-struct-names nm flds #f #f nm #:constructor-name maker*) [(list sty maker pred getters/setters ...) (let-values ([(getters setters) (split getters/setters)]) - (struct-names nm sty (or maker* maker) pred getters setters))])) + (struct-names nm sty maker pred getters setters))])) ;; gets the fields of the parent type, if they exist ;; Option[Struct-Ty] -> Listof[Type] @@ -166,13 +166,12 @@ (define bindings (list* ;; the list of names w/ types - (cons (struct-names-struct-type names) (make-StructType sty)) - (cons (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base))) - (cons (struct-names-predicate names) - (make-pred-ty (if (not covariant?) - (make-StructTop sty) - (subst-all (make-simple-substitution - tvars (map (const Univ) tvars)) poly-base)))) + (make-def-binding (struct-names-struct-type names) (make-StructType sty)) + (make-def-binding (struct-names-predicate names) + (make-pred-ty (if (not covariant?) + (make-StructTop sty) + (subst-all (make-simple-substitution + tvars (map (const Univ) tvars)) poly-base)))) (append (for/list ([g (in-list (struct-names-getters names))] [t (in-list self-fields)] @@ -183,28 +182,31 @@ (->* (list poly-base) t) (->acc (list poly-base) t (list path))))]) (add-struct-fn! g path #f) - (cons g func))) + (make-def-binding g func))) (if mutable (for/list ([s (in-list (struct-names-setters names))] [t (in-list self-fields)] [i (in-naturals parent-count)]) (add-struct-fn! s (make-StructPE poly-base i) #t) - (cons s (poly-wrapper (->* (list poly-base t) -Void)))) + (make-def-binding s (poly-wrapper (->* (list poly-base t) -Void)))) null)))) (add-struct-constructor! (struct-names-constructor names)) - (define def-bindings - (for/list ([b (in-list bindings)]) - (define id (car b)) - (define t (cdr b)) - (register-type id t) - (make-def-binding id t))) - (if si - (cons - (make-def-struct-stx-binding (struct-names-type-name names) si) - def-bindings) - def-bindings)) + (define constructor-binding + (make-def-binding (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base)))) + + (for ([b (cons constructor-binding bindings)]) + (register-type (binding-name b) (def-binding-ty b))) + + (append + (if (free-identifier=? (struct-names-type-name names) + (struct-names-constructor names)) + null + (list constructor-binding)) + (cons + (make-def-struct-stx-binding (struct-names-type-name names) si (def-binding-ty constructor-binding)) + bindings))) (define (register-parsed-struct-sty! ps) (match ps diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 8dd7303a..8635473b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -49,7 +49,7 @@ #:attr name #'nm.nm #:attr mutable (attribute fields.mutable) #:attr type-only (attribute fields.type-only) - #:attr maker (attribute fields.maker))) + #:attr maker (or (attribute fields.maker) #'nm.nm))) (define (parse-define-struct-internal form) (parameterize ([current-orig-stx form]) @@ -331,7 +331,17 @@ (define def-tbl (for/fold ([h (make-immutable-free-id-table)]) ([def (in-list defs)]) - (dict-set h (binding-name def) def))) + ;; TODO figure out why without these checks some tests break + (define (plain-stx-binding? def) + (and (def-stx-binding? def) (not (def-struct-stx-binding? def)))) + (define (merge-def-bindings other-def) + (cond + [(not other-def) def] + [(plain-stx-binding? def) other-def] + [(plain-stx-binding? other-def) def] + [else + (int-err "Two conflicting definitions: ~a ~a" def other-def)])) + (dict-update h (binding-name def) merge-def-bindings #f))) ;; typecheck the expressions and the rhss of defintions ;(displayln "Starting pass2") (for-each tc-toplevel/pass2 forms) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr10765.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr10765.rkt new file mode 100644 index 00000000..8c90cd2c --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr10765.rkt @@ -0,0 +1,17 @@ +#lang racket/load + +(module A typed/racket + + (struct: Point ([x : Integer] [y : Integer])) + + (provide (all-defined-out))) + +(module B typed/racket + (require 'A) + + (: lift (Point -> Point)) + (define (lift p) + (struct-copy Point p [x (add1 (Point-x p))])) + (lift (Point 3 4))) + +(require 'B) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13160.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13160.rkt new file mode 100644 index 00000000..ad0a06db --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13160.rkt @@ -0,0 +1,14 @@ +#lang racket/load + +(module a typed/racket/base + (provide (struct-out the-struct)) + (struct: the-struct ((a : Number)))) + + +(module b typed/racket/base + (require 'a) + (provide (struct-out the-struct))) + +(require 'b) +(the-struct 5) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13161.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13161.rkt new file mode 100644 index 00000000..453c91be --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr13161.rkt @@ -0,0 +1,10 @@ +#lang typed/racket/base + +(provide (struct-out x) + make-x) + +(struct: x () #:transparent) + +(: make-x : -> x) +(define (make-x) + (x)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/structs-across-modules.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/structs-across-modules.rkt new file mode 100644 index 00000000..0cbd9dab --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/structs-across-modules.rkt @@ -0,0 +1,16 @@ +#lang racket/load + +(module t1 typed/racket + (provide node) + (struct: node ())) + +(module t2 typed/racket + (require 't1) + (: v node) + (define v (node))) +(module u racket + (require 't1) + (node)) + +(require 't2) +(require 'u)