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

add #:omit-constructor option to struct form of contract-out

Browse Source
This commit is contained in:
Robby Findler 2013-09-18 14:28:14 -05:00
parent 6f1588fcac
commit a53c69e725
3 changed files with 158 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -1174,8 +1174,8 @@ earlier fields.}}
#:literals (struct rename) #:literals (struct rename)
(contract-out p/c-item ...) (contract-out p/c-item ...)
([p/c-item ([p/c-item
(struct id ((id contract-expr) ...)) (struct id ((id contract-expr) ...) struct-option)
(struct (id identifier) ((id contract-expr) ...)) (struct (id identifier) ((id contract-expr) ...) struct-option)
(rename orig-id id contract-expr) (rename orig-id id contract-expr)
(id contract-expr) (id contract-expr)
(code:line #:∃ poly-variables) (code:line #:∃ poly-variables)
@ -1183,7 +1183,9 @@ earlier fields.}}
(code:line #:∀ poly-variables) (code:line #:∀ poly-variables)
(code:line #:forall poly-variables)] (code:line #:forall poly-variables)]
[poly-variables identifier [poly-variables identifier
(identifier ...)])]{ (identifier ...)]
[struct-option (code:line)
#:omit-constructor])]{
A @racket[_provide-spec] for use in @racket[provide] (currently only for A @racket[_provide-spec] for use in @racket[provide] (currently only for
the same @tech{phase level} as the @racket[provide] form; for example, the same @tech{phase level} as the @racket[provide] form; for example,
@ -1222,6 +1224,8 @@ parent are only used in the contract for the sub-struct's constructor, and
the selector or mutators for the super-struct are not provided. The the selector or mutators for the super-struct are not provided. The
exported structure-type name always doubles as a constructor, even if exported structure-type name always doubles as a constructor, even if
the original structure-type name does not act as a constructor. the original structure-type name does not act as a constructor.
If the @racket[#:omit-constructor] option is present, the constructor
is not provided.
The @racket[#:∃], @racket[#:exists], @racket[#:∀], and @racket[#:forall] The @racket[#:∃], @racket[#:exists], @racket[#:∀], and @racket[#:forall]
clauses define new abstract contracts. The variables are bound in the clauses define new abstract contracts. The variables are bound in the

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

@ -871,6 +871,49 @@
(eval '(require 'provide/contract44-m2)))) (eval '(require 'provide/contract44-m2))))
(test/spec-passed/result
'provide/contract45
'(begin
(eval '(module provide/contract45-m1 racket/base
(require racket/contract)
(struct heap (v) #:transparent)
(provide
(contract-out
(struct heap ([v integer?]) #:omit-constructor)))
(define a-heap (heap 11))
(provide a-heap)))
(eval '(module provide/contract45-m2 racket/base
(require racket/contract 'provide/contract45-m1)
(define provide/contract45-x (heap-v a-heap))
(provide provide/contract45-x)))
(eval '(require 'provide/contract45-m2))
(eval 'provide/contract45-x))
11)
(test/spec-passed/result
'provide/contract46
'(begin
(eval '(module provide/contract46-m1 racket/base
(require racket/contract/base)
(provide
(contract-out
(struct s ([x any/c]) #:omit-constructor)))
(struct s (x))
(define an-s (s 123))
(provide an-s)))
(eval '(module provide/contract46-m2 racket/base
(require 'provide/contract46-m1
racket/match)
(define provide/contract46-x
(match an-s
[(s x) x]))
(provide provide/contract46-x)))
(eval '(require 'provide/contract46-m2))
(eval 'provide/contract46-x))
123)
(contract-error-test (contract-error-test
'contract-error-test8 'contract-error-test8
#'(begin #'(begin
@ -1019,6 +1062,36 @@
;; testing that the error says "contract-out" and not "provide/contract" ;; testing that the error says "contract-out" and not "provide/contract"
(regexp-match #rx"contract-out: found 2 fields" (exn-message x))))) (regexp-match #rx"contract-out: found 2 fields" (exn-message x)))))
(contract-error-test
'contract-error-test19
#'(begin
(eval '(module pce19-bug racket
(struct point (x y))
(provide (contract-out
(struct point ([x integer?] [y integer?])
#:omit-constructor)))))
(eval '(module pce19-b racket
(require 'pce19-bug)
make-point)))
(λ (x)
(and (exn:fail:syntax? x)
(regexp-match #rx"unbound identifier .* make-point" (exn-message x)))))
(contract-error-test
'contract-error-test20
#'(begin
(eval '(module pce20-bug racket
(struct point (x y))
(provide (contract-out
(struct point ([x integer?] [y integer?])
#:omit-constructor)))))
(eval '(module pce20-b racket
(require 'pce20-bug)
point)))
(λ (x)
(and (exn:fail:syntax? x)
(regexp-match #rx"point: .* cannot be used as an expression" (exn-message x)))))
(contract-eval (contract-eval
`(,test `(,test
'pos 'pos
@ -1101,8 +1174,6 @@
(eval 'contract-out-rename1-my-f)) (eval 'contract-out-rename1-my-f))
11) 11)
(contract-eval (contract-eval
'(module contract-test-suite-inferred-name1 racket/base '(module contract-test-suite-inferred-name1 racket/base
(require racket/contract) (require racket/contract)

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

@ -188,8 +188,8 @@
clause)] clause)]
[else [else
(syntax-case (cadr clauses) () (syntax-case (cadr clauses) ()
[x [x
(identifier? #'x) (identifier? #'x)
(if just-check-errors? (if just-check-errors?
(loop (cddr clauses) exists-binders) (loop (cddr clauses) exists-binders)
(with-syntax ([(x-gen) (generate-temporaries #'(x))]) (with-syntax ([(x-gen) (generate-temporaries #'(x))])
@ -245,18 +245,27 @@
(syntax this-name))] (syntax this-name))]
[(rename . _) [(rename . _)
(raise-syntax-error who "malformed rename clause" provide-stx clause)] (raise-syntax-error who "malformed rename clause" provide-stx clause)]
[(struct struct-name ((field-name contract) ...)) [(struct struct-name ((field-name contract) ...) options ...)
(and (well-formed-struct-name? (syntax struct-name)) (and (well-formed-struct-name? (syntax struct-name))
(andmap identifier? (syntax->list (syntax (field-name ...))))) (andmap identifier? (syntax->list (syntax (field-name ...)))))
(begin (let ()
(for ([option (in-list (syntax->list #'(options ...)))])
(unless (member (syntax-e option) '(#:omit-constructor))
(raise-syntax-error who
"malformed struct option"
provide-stx
option)))
(add-to-dups-table #'struct-name) (add-to-dups-table #'struct-name)
(define omit-constructor?
(member '#:omit-constructor (map syntax-e (syntax->list #'(options ...)))))
(if just-check-errors? (if just-check-errors?
(loop (cdr clauses) exists-binders) (loop (cdr clauses) exists-binders)
(let ([sc (build-struct-code provide-stx (let ([sc (build-struct-code provide-stx
(syntax struct-name) (syntax struct-name)
(syntax->list (syntax (field-name ...))) (syntax->list (syntax (field-name ...)))
(map (λ (x) (add-exists-binders x exists-binders)) (map (λ (x) (add-exists-binders x exists-binders))
(syntax->list (syntax (contract ...)))))]) (syntax->list (syntax (contract ...))))
omit-constructor?)])
(cons sc (loop (cdr clauses) exists-binders)))))] (cons sc (loop (cdr clauses) exists-binders)))))]
[(struct name) [(struct name)
(identifier? (syntax name)) (identifier? (syntax name))
@ -270,26 +279,25 @@
"name must be an identifier or two identifiers with parens around them" "name must be an identifier or two identifiers with parens around them"
provide-stx provide-stx
(syntax name))] (syntax name))]
[(struct name (fields ...)) [(struct name (fields ...) options ...)
(for-each (λ (field) (let ()
(syntax-case field () (for ([field [in-list (syntax->list (syntax (fields ...)))]])
[(x y) (syntax-case field ()
(identifier? (syntax x)) [(x y)
(void)] (identifier? (syntax x))
[(x y) (void)]
(raise-syntax-error who [(x y)
"malformed struct field, expected identifier" (raise-syntax-error who
provide-stx "malformed struct field, expected identifier"
(syntax x))] provide-stx
[else (syntax x))]
(raise-syntax-error who [else
"malformed struct field" (raise-syntax-error who
provide-stx "malformed struct field"
field)])) provide-stx
(syntax->list (syntax (fields ...)))) field)]))
;; if we didn't find a bad field something is wrong!
;; if we didn't find a bad field something is wrong! (raise-syntax-error who "internal error.1" provide-stx clause))]
(raise-syntax-error who "internal error.1" provide-stx clause)]
[(struct name . fields) [(struct name . fields)
(raise-syntax-error who (raise-syntax-error who
"malformed struct fields" "malformed struct fields"
@ -331,7 +339,8 @@
;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
;; constructs the code for a struct clause ;; constructs the code for a struct clause
;; first arg is the original syntax object, for source locations ;; first arg is the original syntax object, for source locations
(define (build-struct-code stx struct-name-position field-names field-contracts) (define (build-struct-code stx struct-name-position field-names field-contracts
omit-constructor?)
(let* ([struct-name (syntax-case struct-name-position () (let* ([struct-name (syntax-case struct-name-position ()
[(a b) (syntax a)] [(a b) (syntax a)]
[else struct-name-position])] [else struct-name-position])]
@ -372,12 +381,13 @@
field-names field-names
field-contracts)] field-contracts)]
[struct:struct-name [struct:struct-name
(datum->syntax (or (list-ref the-struct-info 0)
struct-name (datum->syntax
(string->symbol struct-name
(string-append (string->symbol
"struct:" (string-append
(symbol->string (syntax-e struct-name)))))] "struct:"
(symbol->string (syntax-e struct-name))))))]
[-struct:struct-name [-struct:struct-name
(datum->syntax (datum->syntax
@ -508,15 +518,17 @@
[(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) #f)]
[(constructor-code constructor-new-name) [(constructor-code constructor-new-name)
(code-for-one-id/new-name (if omit-constructor?
stx #'((void) (void))
chaperone-constructor-id struct-name (code-for-one-id/new-name
(build-constructor-contract stx stx
field-contract-ids chaperone-constructor-id struct-name
predicate-id) (build-constructor-contract stx
constructor-id field-contract-ids
#t predicate-id)
(not type-is-only-constructor?))] constructor-id
#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)
@ -555,25 +567,26 @@
[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)])
(define proc
#`(λ ()
(list (quote-syntax -struct:struct-name)
#,(if type-is-only-constructor?
#'(quote-syntax id-rename)
#'(quote-syntax constructor-new-name))
(quote-syntax predicate-new-name)
(list (quote-syntax rev-selector-new-names) ...
(quote-syntax rev-selector-old-names) ...)
(list mutator-id-info ...)
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
#,(let ([proc #,(if (and type-is-constructor? (not omit-constructor?))
#`(lambda () #`(make-applicable-struct-info
(list (quote-syntax -struct:struct-name) #,proc
#,(if type-is-only-constructor? (lambda ()
#'(quote-syntax id-rename) (quote-syntax constructor-new-name)))
#'(quote-syntax constructor-new-name)) #`(make-struct-info #,proc)))))]
(quote-syntax predicate-new-name)
(list (quote-syntax rev-selector-new-names) ...
(quote-syntax rev-selector-old-names) ...)
(list mutator-id-info ...)
super-id))])
(if type-is-constructor?
#`(make-applicable-struct-info #,proc
(lambda ()
(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]
@ -633,7 +646,8 @@
;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol)) ;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol))
;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs
(define (get-field-counts/struct-names struct-name provide-stx) (define (get-field-counts/struct-names struct-name provide-stx)
(let loop ([parent-info-id struct-name]) (let loop ([parent-info-id struct-name]
[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))]) (a:lookup-struct-info parent-info-id provide-stx))])
@ -647,12 +661,13 @@
(not (last fields))) (not (last fields)))
(raise-syntax-error (raise-syntax-error
who who
"cannot determine the number of fields in super struct" (format "cannot determine the number of fields in ~astruct"
(if orig-struct? "" "parent "))
provide-stx provide-stx
struct-name)] struct-name)]
[else [else
(cons (cons (length fields) (predicate->struct-name provide-stx predicate)) (cons (cons (length fields) (predicate->struct-name provide-stx predicate))
(loop (list-ref parent-info 5)))]))])))) (loop (list-ref parent-info 5) #f))]))]))))
(define (predicate->struct-name orig-stx stx) (define (predicate->struct-name orig-stx stx)
(and stx (and stx
@ -822,10 +837,10 @@
[else [else
(for ([clause (in-list p/c-clauses)]) (for ([clause (in-list p/c-clauses)])
(syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y))) (syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
[(struct a ((fld ctc) ...)) [(struct a ((fld ctc) ...) options ...)
(identifier? #'a) (identifier? #'a)
(add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))] (add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))]
[(struct (a b) ((fld ctc) ...)) [(struct (a b) ((fld ctc) ...) options ...)
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))] (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)])) [_ (void)]))
(with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]) (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)])