suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

contract-out: struct, keep original struct id

Browse Source 
The first time a struct is provided through `(contract-out (struct id ....))`,
 save `id` to access its transformer binding later.

On reprovides:
- hang on to the original `id`
- use its transformer to recover the original predicate/accessor/mutator names

Also, fix a bug where the order of the mutator ids reported by the
struct info was getting reversed

Probably, nobody noticed that bug. They'd have to work around the renaming
issue in #2572 first.
This commit is contained in:
Ben Greenman 2019-04-20 15:55:38 -04:00 committed by Robby Findler
parent ddaf3f5022
commit b40e247edd
3 changed files with 125 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -1232,6 +1232,7 @@
(test/spec-passed (test/spec-passed
'provide/contract67 'provide/contract67
;; https://github.com/racket/racket/issues/2469
'(let () '(let ()
(eval '(module provide/contract67-a racket/base (eval '(module provide/contract67-a racket/base
(require racket/contract/base) (require racket/contract/base)
@ -1278,6 +1279,23 @@
(eval '(dynamic-require ''provide/contract69-b 'answer))) (eval '(dynamic-require ''provide/contract69-b 'answer)))
'#f) '#f)
(test/spec-passed
'provide/contract70
;; https://github.com/racket/racket/issues/2572
'(let ()
(eval '(module provide/contract70-a racket/base
(require racket/contract/base)
(struct stream (x [y #:mutable]))
(provide (contract-out (struct stream ([x any/c] [y any/c]))))))
(eval '(module provide/contract70-b racket/base
(require 'provide/contract70-a racket/contract/base)
(provide (contract-out (struct stream ([x any/c] [y any/c]))))))
(eval '(module provide/contract70-c racket/base
(require 'provide/contract70-b racket/contract/base)
(void stream stream? stream-x stream-y set-stream-y!)))))
(contract-error-test (contract-error-test
'provide/contract-struct-out 'provide/contract-struct-out
#'(begin #'(begin

4
racket/collects/racket/contract/private/helpers.rkt
View File

@ -21,7 +21,7 @@
(define (update-loc stx loc) (define (update-loc stx loc)
(datum->syntax stx (syntax-e stx) loc)) (datum->syntax stx (syntax-e stx) loc))
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) ;; lookup-struct-info : syntax -> (union #f struct-info?)
(define (lookup-struct-info stx provide-stx) (define (lookup-struct-info stx provide-stx)
(define id (syntax-case stx () (define id (syntax-case stx ()
[(a b) (syntax a)] [(a b) (syntax a)]
@ -34,7 +34,7 @@
(syntax-e #'x)] (syntax-e #'x)]
[_ 'provide/contract])) [_ 'provide/contract]))
(if (struct-info? v) (if (struct-info? v)
(extract-struct-info v) v
(raise-syntax-error error-name (raise-syntax-error error-name
"expected a struct name" "expected a struct name"
provide-stx provide-stx

132
racket/collects/racket/contract/private/provide.rkt
View File

@ -43,15 +43,44 @@
stx)] stx)]
[_ (syntax orig)]))) [_ (syntax orig)])))
(define-for-syntax make-applicable-struct-info ;; make-contract-out-redirect-struct-info
(letrec-values ([(struct: make- ? ref set!) ;; : (-> (-> (and/c struct-info? list?)) (-> identifier?) struct-info?)
(make-struct-type 'self-ctor-struct-info struct:struct-info ;; Create a struct-info? value from two thunks:
;; the 1st must be a valid argument for `make-struct-info`, and
;; the 2nd must return an identifier for a structure type descriptor.
;; The 2nd thunk is used to recover the original names for a struct --- from before
;; `contract-out` started to mangle them.
;;
;; make-applicable-contract-out-redirect-struct-info
;; : (-> (-> (and/c struct-info? list?)) (-> identifier?) (-> identifier?) struct-info?)
;; Similar to the above, but the 3rd thunk must return an identifier for a
;; contract-protected constructor.
;; Creates a value that can be applied to construct instances of the struct type.
;;
;; undo-contract-out-redirect
;; : (-> any/c (or/c identifier? #f))
;; Return the original struct name associated with the argument, or #f if
;; the input is not an indirect struct info.
(define-values-for-syntax [make-contract-out-redirect-struct-info
make-applicable-contract-out-redirect-struct-info
undo-contract-out-redirect]
(let-values ([(struct:r make-r r? r-ref r-set!)
(make-struct-type
'contract-out-redirect-struct-info struct:struct-info
1 0 #f
'()
(current-inspector) #f '(0))])
(letrec-values ([(struct:app-r make-app-r app-r? app-r-ref app-r-set!)
(make-struct-type
'applicable-contract-out-redirect-struct-info struct:r
1 0 #f 1 0 #f
(list (cons prop:procedure (list (cons prop:procedure
(lambda (v stx) (lambda (v stx)
(self-ctor-transformer ((ref v 0)) stx)))) (self-ctor-transformer ((app-r-ref v 0)) stx))))
(current-inspector) #f '(0))]) (current-inspector) #f '(0))])
make-)) (define (undo-contract-out-redirect v)
(and (r? v) ((r-ref v 0))))
(values make-r make-app-r undo-contract-out-redirect))))
(begin-for-syntax (begin-for-syntax
@ -703,9 +732,16 @@
(car (car pp)))))] (car (car pp)))))]
[the-struct-info (a:lookup-struct-info struct-name-position provide-stx)] [the-struct-info (a:lookup-struct-info struct-name-position provide-stx)]
[constructor-id (list-ref the-struct-info 1)] [orig-struct-name
[predicate-id (list-ref the-struct-info 2)] (or (undo-contract-out-redirect the-struct-info)
[selector-ids (reverse (list-ref the-struct-info 3))] struct-name)]
[the-struct-info-list (extract-struct-info the-struct-info)]
[orig-struct-info-list (extract-struct-info (syntax-local-value orig-struct-name))]
[constructor-id (list-ref the-struct-info-list 1)]
[predicate-id (list-ref the-struct-info-list 2)]
[orig-predicate-id (list-ref orig-struct-info-list 2)]
[selector-ids (reverse (list-ref the-struct-info-list 3))]
[orig-selector-ids (reverse (list-ref orig-struct-info-list 3))]
[type-is-only-constructor? (free-identifier=? constructor-id struct-name)] [type-is-only-constructor? (free-identifier=? constructor-id struct-name)]
; I think there's no way to detect when the struct-name binding isn't a constructor ; I think there's no way to detect when the struct-name binding isn't a constructor
[type-is-constructor? #t] [type-is-constructor? #t]
@ -717,7 +753,8 @@
(parent-struct-count . <= . i)) (parent-struct-count . <= . i))
id id
#t))] #t))]
[mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier)) [mutator-ids (reverse (list-ref the-struct-info-list 4))] ;; (listof (union #f identifier))
[orig-mutator-ids (reverse (list-ref orig-struct-info-list 4))]
[field-contract-ids (map (λ (field-name field-contract) [field-contract-ids (map (λ (field-name field-contract)
(mangled-id-scope (mangled-id-scope
(a:mangle-id "provide/contract-field-contract" (a:mangle-id "provide/contract-field-contract"
@ -726,7 +763,7 @@
field-names field-names
field-contracts)] field-contracts)]
[struct:struct-name [struct:struct-name
(or (list-ref the-struct-info 0) (or (list-ref the-struct-info-list 0)
(datum->syntax (datum->syntax
struct-name struct-name
(string->symbol (string->symbol
@ -824,35 +861,33 @@
(cdr selector-strs) (cdr selector-strs)
(cdr field-names)))]))) (cdr field-names)))])))
(with-syntax ([((selector-codes selector-new-names) ...) (with-syntax ([((selector-codes selector-new-names) ...)
(filter (for/list ([selector-id (in-list selector-ids)]
(λ (x) x) [orig-selector-id (in-list orig-selector-ids)]
(map/count (λ (selector-id field-contract-id index) [field-contract-id (in-list field-contract-ids)]
(if (is-new-id? index) [index (in-naturals)]
#:when (is-new-id? index))
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
selector-id #f selector-id #f
(build-selector-contract struct-name (build-selector-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
#f) (datum->syntax stx orig-selector-id)))]
#f))
selector-ids
field-contract-ids))]
[(rev-selector-old-names ...) [(rev-selector-old-names ...)
(reverse (reverse
(filter
(λ (x) x)
(for/list ([selector-id (in-list selector-ids)] (for/list ([selector-id (in-list selector-ids)]
[index (in-naturals)]) [index (in-naturals)]
(if (is-new-id? index) #:unless (is-new-id? index))
#f
(let ([in-map (free-identifier-mapping-get struct-id-mapping (let ([in-map (free-identifier-mapping-get struct-id-mapping
selector-id selector-id
(λ () #f))]) (λ () #f))])
(or in-map (or in-map
selector-id))))))] selector-id))))]
[(mutator-codes/mutator-new-names ...) [(mutator-codes/mutator-new-names ...)
(map/count (λ (mutator-id field-contract-id index) (for/list ([mutator-id (in-list mutator-ids)]
[orig-mutator-id (in-list orig-mutator-ids)]
[field-contract-id (in-list field-contract-ids)]
[index (in-naturals)])
(if (and mutator-id (is-new-id? index)) (if (and mutator-id (is-new-id? index))
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
@ -860,12 +895,11 @@
(build-mutator-contract struct-name (build-mutator-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
#f) (datum->syntax stx orig-mutator-id))
#f)) #f))]
mutator-ids
field-contract-ids)]
[(predicate-code predicate-new-name) [(predicate-code predicate-new-name)
(code-for-one-id/new-name stx predicate-id #f (syntax predicate/c) #f)] (code-for-one-id/new-name stx predicate-id #f (syntax predicate/c)
(datum->syntax stx orig-predicate-id))]
[(constructor-code constructor-new-name) [(constructor-code constructor-new-name)
(if omit-constructor? (if omit-constructor?
#'((void) (void)) #'((void) (void))
@ -893,12 +927,10 @@
[(field-contracts ...) field-contracts] [(field-contracts ...) field-contracts]
[(field-contract-ids ...) field-contract-ids]) [(field-contract-ids ...) field-contract-ids])
(with-syntax ([((mutator-codes mutator-new-names) ...) (with-syntax ([((mutator-codes _) ...)
(filter syntax-e (syntax->list #'(mutator-codes/mutator-new-names ...)))]) (filter syntax-e (syntax->list #'(mutator-codes/mutator-new-names ...)))])
(with-syntax ([(rev-selector-new-names ...) (with-syntax ([(rev-selector-new-names ...)
(reverse (syntax->list (syntax (selector-new-names ...))))] (reverse (syntax->list (syntax (selector-new-names ...))))])
[(rev-mutator-new-names ...)
(reverse (syntax->list (syntax (mutator-new-names ...))))])
(with-syntax ([struct-code (with-syntax ([struct-code
(with-syntax ([id-rename (with-syntax ([id-rename
(or (free-identifier-mapping-get struct-id-mapping (or (free-identifier-mapping-get struct-id-mapping
@ -908,6 +940,7 @@
"internal error.2: ~s" "internal error.2: ~s"
struct-name))] struct-name))]
[struct-name struct-name] [struct-name struct-name]
[orig-struct-name orig-struct-name]
[-struct:struct-name -struct:struct-name] [-struct:struct-name -struct:struct-name]
[super-id [super-id
(if (boolean? super-id) (if (boolean? super-id)
@ -919,14 +952,14 @@
(λ () #f)) (λ () #f))
super-id)]) super-id)])
(syntax (quote-syntax the-super-id))))] (syntax (quote-syntax the-super-id))))]
[(mutator-id-info ...) [(rev-mutator-id-info ...)
(reverse
(for/list ([x (in-list (for/list ([x (in-list
(syntax->list (syntax->list
#'(mutator-codes/mutator-new-names #'(mutator-codes/mutator-new-names ...)))])
...)))])
(syntax-case x () (syntax-case x ()
[(a b) #'(quote-syntax b)] [(a b) #'(quote-syntax b)]
[else #f]))] [else #f])))]
[(exported-selector-ids ...) (reverse selector-ids)]) [(exported-selector-ids ...) (reverse selector-ids)])
(define proc (define proc
#`(λ () #`(λ ()
@ -937,17 +970,22 @@
(quote-syntax predicate-new-name) (quote-syntax predicate-new-name)
(list (quote-syntax rev-selector-new-names) ... (list (quote-syntax rev-selector-new-names) ...
(quote-syntax rev-selector-old-names) ...) (quote-syntax rev-selector-old-names) ...)
(list mutator-id-info ...) (list rev-mutator-id-info ...)
super-id))) super-id)))
#`(begin #`(begin
(provide (rename-out [id-rename struct-name])) (provide (rename-out [id-rename struct-name]))
(define-syntax id-rename (define-syntax id-rename
#,(if (and type-is-constructor? (not omit-constructor?)) #,(if (and type-is-constructor? (not omit-constructor?))
#`(make-applicable-struct-info #`(make-applicable-contract-out-redirect-struct-info
#,proc #,proc
(lambda ()
(quote-syntax orig-struct-name))
(lambda () (lambda ()
(quote-syntax constructor-new-name))) (quote-syntax constructor-new-name)))
#`(make-struct-info #,proc)))))] #`(make-contract-out-redirect-struct-info
#,proc
(lambda ()
(quote-syntax orig-struct-name)))))))]
[struct:struct-name struct:struct-name] [struct:struct-name struct:struct-name]
[-struct:struct-name -struct:struct-name] [-struct:struct-name -struct:struct-name]
[struct-name struct-name] [struct-name struct-name]
@ -990,16 +1028,6 @@
field-contract-ids ...)) field-contract-ids ...))
(provide (rename-out [-struct:struct-name struct:struct-name])))))))))) (provide (rename-out [-struct:struct-name struct:struct-name]))))))))))
(define (map/count f . ls)
(let loop ([ls ls]
[i 0])
(cond
[(andmap null? ls) '()]
[(ormap null? ls) (error 'map/count "mismatched lists")]
[else (cons (apply f (append (map car ls) (list i)))
(loop (map cdr ls)
(+ i 1)))])))
;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) ;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
(define (andmap/count f l1) (define (andmap/count f l1)
(let loop ([l1 l1] (let loop ([l1 l1]
@ -1017,7 +1045,7 @@
[orig-struct? #t]) [orig-struct? #t])
(let ([parent-info (let ([parent-info
(and (identifier? parent-info-id) (and (identifier? parent-info-id)
(a:lookup-struct-info parent-info-id provide-stx))]) (extract-struct-info (a:lookup-struct-info parent-info-id provide-stx)))])
(cond (cond
[(boolean? parent-info) null] [(boolean? parent-info) null]
[else [else