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

adjust (provide/contract (struct ....)) to work with new constructor-name convention

Browse Source
This commit is contained in:
Matthew Flatt 2010-05-04 18:25:01 -06:00
parent 2f2bdce759
commit bf5967f30b
2 changed files with 83 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,6 +5,7 @@
(require (for-syntax racket/base (require (for-syntax racket/base
racket/list racket/list
racket/struct-info
(prefix-in a: "helpers.ss")) (prefix-in a: "helpers.ss"))
"arrow.ss" "arrow.ss"
"base.ss" "base.ss"
@ -18,6 +19,25 @@
[(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)])) [(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (self-ctor-transformer orig stx)
(with-syntax ([orig orig])
(syntax-case stx ()
[(_ arg ...) (datum->syntax stx
(syntax-e (syntax (orig arg ...)))
stx
stx)]
[_ (syntax orig)])))
(define-for-syntax make-applicable-struct-info
(letrec-values ([(struct: make- ? ref set!)
(make-struct-type 'self-ctor-struct-info struct:struct-info
1 0 #f
(list (cons prop:procedure
(lambda (v stx)
(self-ctor-transformer ((ref v 0)) stx))))
(current-inspector) #f '(0))])
make-))
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source) (define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
(make-set!-transformer (make-set!-transformer
(let ([saved-id-table (make-hasheq)]) (let ([saved-id-table (make-hasheq)])
@ -160,7 +180,7 @@
(begin (begin
(add-to-dups-table #'new-name) (add-to-dups-table #'new-name)
(cons (code-for-one-id provide-stx (cons (code-for-one-id provide-stx
(syntax this-name) (syntax this-name) #f
(add-exists-binders (syntax contract) exists-binders) (add-exists-binders (syntax contract) exists-binders)
(syntax new-name)) (syntax new-name))
(loop (cdr clauses) exists-binders)))] (loop (cdr clauses) exists-binders)))]
@ -229,7 +249,7 @@
(begin (begin
(add-to-dups-table #'name) (add-to-dups-table #'name)
(cons (code-for-one-id provide-stx (cons (code-for-one-id provide-stx
(syntax name) (syntax name) #f
(add-exists-binders (syntax contract) (add-exists-binders (syntax contract)
exists-binders) exists-binders)
#f) #f)
@ -279,6 +299,8 @@
[constructor-id (list-ref struct-info 1)] [constructor-id (list-ref struct-info 1)]
[predicate-id (list-ref struct-info 2)] [predicate-id (list-ref struct-info 2)]
[selector-ids (reverse (list-ref struct-info 3))] [selector-ids (reverse (list-ref struct-info 3))]
[type-is-only-constructor? (free-identifier=? constructor-id struct-name)]
[type-is-constructor? #t] ; I think there's no way to detect when the struct-name binding isn't a constructor
[is-id-ok? [is-id-ok?
(λ (id i) (λ (id i)
(if (or (not parent-struct-count) (if (or (not parent-struct-count)
@ -356,8 +378,8 @@
[else (cons (- (car c) (cadr c)) [else (cons (- (car c) (cadr c))
(loop (cdr c)))]))] (loop (cdr c)))]))]
[names (map cdr all-parent-struct-count/names)] [names (map cdr all-parent-struct-count/names)]
[maker-name (format "~a" (syntax-e constructor-id))] [predicate-name (format "~a" (syntax-e predicate-id))]
[struct-name (substring maker-name 5 (string-length maker-name))]) [struct-name (substring predicate-name 0 (sub1 (string-length predicate-name)))])
(let loop ([count (car relative-counts)] (let loop ([count (car relative-counts)]
[name (car names)] [name (car names)]
[counts (cdr relative-counts)] [counts (cdr relative-counts)]
@ -400,7 +422,7 @@
(if (is-new-id? index) (if (is-new-id? index)
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
selector-id selector-id #f
(build-selector-contract struct-name (build-selector-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
@ -421,7 +443,7 @@
(map/count (λ (mutator-id field-contract-id index) (map/count (λ (mutator-id field-contract-id index)
(if (and mutator-id (is-new-id? index)) (if (and mutator-id (is-new-id? index))
(code-for-one-id/new-name stx (code-for-one-id/new-name stx
mutator-id mutator-id #f
(build-mutator-contract struct-name (build-mutator-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
@ -430,16 +452,17 @@
mutator-ids mutator-ids
field-contract-ids)] field-contract-ids)]
[(predicate-code predicate-new-name) [(predicate-code predicate-new-name)
(code-for-one-id/new-name stx predicate-id (syntax (-> any/c boolean?)) #f)] (code-for-one-id/new-name stx predicate-id #f (syntax (-> any/c boolean?)) #f)]
[(constructor-code constructor-new-name) [(constructor-code constructor-new-name)
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
constructor-id constructor-id struct-name
(build-constructor-contract stx (build-constructor-contract stx
field-contract-ids field-contract-ids
predicate-id) predicate-id)
#f #f
#t)] #t
(not type-is-only-constructor?))]
[(field-contract-id-definitions ...) [(field-contract-id-definitions ...)
(filter values (map (λ (field-contract-id field-contract) (filter values (map (λ (field-contract-id field-contract)
@ -470,7 +493,7 @@
[(mutator-id-info ...) [(mutator-id-info ...)
(map (λ (x) (map (λ (x)
(syntax-case x () (syntax-case x ()
[(a b) #'(slc #'b)] [(a b) #'(quote-syntax b)]
[else #f])) [else #f]))
(syntax->list #'(mutator-codes/mutator-new-names ...)))] (syntax->list #'(mutator-codes/mutator-new-names ...)))]
[(exported-selector-ids ...) (reverse selector-ids)] [(exported-selector-ids ...) (reverse selector-ids)]
@ -478,21 +501,22 @@
#`(begin #`(begin
(provide (rename-out [id-rename struct-name])) (provide (rename-out [id-rename struct-name]))
(define-syntax id-rename (define-syntax id-rename
(let ([slc (syntax-local-certifier)]) #,(let ([proc
#; #`(lambda ()
(list (slc #'-struct:struct-name) (list (quote-syntax -struct:struct-name)
(slc #'#,constructor-id) #,(if type-is-only-constructor?
(slc #'#,predicate-id) #'(quote-syntax id-rename)
(list (slc #'exported-selector-ids) ...) #'(quote-syntax constructor-new-name))
(list mutator-id-info ...) (quote-syntax predicate-new-name)
super-id) (list (quote-syntax rev-selector-new-names) ...
(list (slc #'-struct:struct-name) (quote-syntax rev-selector-old-names) ...)
(slc #'constructor-new-name) (list mutator-id-info ...)
(slc #'predicate-new-name) super-id))])
(list (slc #'rev-selector-new-names) ... (if type-is-constructor?
(slc #'rev-selector-old-names) ...) #`(make-applicable-struct-info #,proc
(list mutator-id-info ...) (lambda ()
super-id)))))] (quote-syntax constructor-new-name)))
#`(make-struct-info #,proc))))))]
[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]
@ -604,8 +628,8 @@
;; given the syntax for an identifier and a contract, ;; given the syntax for an identifier and a contract,
;; builds a begin expression for the entire contract and provide ;; builds a begin expression for the entire contract and provide
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define (code-for-one-id stx id ctrct user-rename-id) (define (code-for-one-id stx id reflect-id ctrct user-rename-id)
(with-syntax ([(code id) (code-for-one-id/new-name stx id ctrct user-rename-id)]) (with-syntax ([(code id) (code-for-one-id/new-name stx id reflect-id ctrct user-rename-id)])
(syntax code))) (syntax code)))
;; code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) ;; code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
@ -614,28 +638,33 @@
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define code-for-one-id/new-name (define code-for-one-id/new-name
(case-lambda (case-lambda
[(stx id ctrct user-rename-id) [(stx id reflect-id ctrct user-rename-id)
(code-for-one-id/new-name stx id ctrct user-rename-id #f)] (code-for-one-id/new-name stx id reflect-id ctrct user-rename-id #f #t)]
[(stx id ctrct user-rename-id mangle-for-maker?) [(stx id reflect-id ctrct user-rename-id mangle-for-maker?)
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) (code-for-one-id/new-name id reflect-id ctrct user-rename-id mangle-for-maker? #t)]
[(stx id reflect-id ctrct user-rename-id mangle-for-maker? provide?)
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]
[ex-id (or reflect-id id)])
(with-syntax ([id-rename ((if mangle-for-maker? (with-syntax ([id-rename ((if mangle-for-maker?
a:mangle-id-for-maker a:mangle-id-for-maker
a:mangle-id) a:mangle-id)
provide-stx provide-stx
"provide/contract-id" "provide/contract-id"
(or user-rename-id id))] (or user-rename-id ex-id))]
[contract-id (if no-need-to-check-ctrct? [contract-id (if no-need-to-check-ctrct?
ctrct ctrct
(a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-contract-id" "provide/contract-contract-id"
(or user-rename-id id)))] (or user-rename-id ex-id)))]
[pos-module-source (a:mangle-id provide-stx [pos-module-source (a:mangle-id provide-stx
"provide/contract-pos-module-source" "provide/contract-pos-module-source"
(or user-rename-id id))] (or user-rename-id ex-id))]
[pos-stx (datum->syntax id 'here)] [pos-stx (datum->syntax id 'here)]
[id id] [id id]
[ctrct (syntax-property ctrct 'inferred-name id)] [ex-id ex-id]
[ctrct (syntax-property ctrct 'inferred-name ex-id)]
[external-name (or user-rename-id id)] [external-name (or user-rename-id id)]
[reflect-external-name (or user-rename-id ex-id)]
[where-stx stx]) [where-stx stx])
(with-syntax ([extra-test (with-syntax ([extra-test
(syntax-case #'ctrct (->) (syntax-case #'ctrct (->)
@ -651,15 +680,17 @@
#,@(if no-need-to-check-ctrct? #,@(if no-need-to-check-ctrct?
(list) (list)
(list #'(define contract-id (list #'(define contract-id
(let ([id ctrct]) ;; let is here to give the right name. (let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract 'provide/contract id))))) (verify-contract 'provide/contract ex-id)))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax external-name) (quote-syntax reflect-external-name)
(quote-syntax pos-module-source))) (quote-syntax pos-module-source)))
(provide (rename-out [id-rename external-name]))))]) #,@(if provide?
(list #`(provide (rename-out [id-rename external-name])))
null)))])
(syntax-local-lift-module-end-declaration (syntax-local-lift-module-end-declaration
#`(begin #`(begin

23
collects/scribblings/reference/contracts.scrbl
View File

@ -725,16 +725,19 @@ first variable (the internal name) with the name specified by the
second variable (the external name). second variable (the external name).
The @racket[struct] form of a @racket[provide/contract] clause The @racket[struct] form of a @racket[provide/contract] clause
provides a structure definition, and each field has a contract that provides a structure-type definition, and each field has a contract
dictates the contents of the fields. The struct definition must come that dictates the contents of the fields. The structure-type
before the provide clause in the module's body. If the struct has a definition must appear before the @racket[provide] clause within the
parent, the second @racket[struct] form (above) must be used, with the enclosing module. If the structure type has a parent, the second
first name referring to the struct itself and the second name @racket[struct] form (above) must be used, with the first name
referring to the parent struct. Unlike @racket[define-struct], referring to the structure type to export and the second name
however, all of the fields (and their contracts) must be listed. The referring to the parent structure type. Unlike a @racket[struct]
contract on the fields that the sub-struct shares with its parent are definition, however, all of the fields (and their contracts) must be
only used in the contract for the sub-struct's maker, and the selector listed. The contract on the fields that the sub-struct shares with its
or mutators for the super-struct are not provided. parent are only used in the contract for the sub-struct's maker, and
the selector or mutators for the super-struct are not provided. The
exported structure-type name always doubles as a constructor, even if
the original structure-type name does not act as a constructor.
The @racket[#:∃] and @racket[#:exists] clauses define new abstract The @racket[#:∃] and @racket[#:exists] clauses define new abstract
contracts. The variables are bound in the remainder of the @racket[provide/contract] contracts. The variables are bound in the remainder of the @racket[provide/contract]