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
This commit is contained in:
Eric Dobson
parent
bcc606575c
commit
85f997b4c7
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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])))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(provide (struct-out x)
|
||||
make-x)
|
||||
|
||||
(struct: x () #:transparent)
|
||||
|
||||
(: make-x : -> x)
|
||||
(define (make-x)
|
||||
(x))
|
||||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue
Block a user