From 5c109946c27b6750ad80a0dc49c3fd1aab9a4502 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 16 Feb 2013 16:52:32 -0600 Subject: [PATCH] add support to struct/dc to name the selector directly and use that in struct/c closes PR 13054 closes PR 13461 related to PR 13050 --- .../racket/contract/private/struct-dc.rkt | 14 ++++--- .../scribblings/reference/contracts.scrbl | 9 ++++- collects/tests/racket/contract-test.rktl | 39 +++++++++++++++++++ 3 files changed, 56 insertions(+), 6 deletions(-) diff --git a/collects/racket/contract/private/struct-dc.rkt b/collects/racket/contract/private/struct-dc.rkt index a852d14985..3f259690bd 100644 --- a/collects/racket/contract/private/struct-dc.rkt +++ b/collects/racket/contract/private/struct-dc.rkt @@ -533,6 +533,9 @@ [sel-id (identifier? #'sel-id) #t] + [(#:selector sel-id) + (identifier? #'sel-id) + #t] [(sel-id #:parent struct-id) (and (identifier? #'sel-id) (identifier? #'struct-id)) @@ -547,8 +550,6 @@ [(sel-name (dep-name ...) stuff1 . stuff) ;; need stuff1 here so that things like [a (>=/c x)] do not fall into this case (sel-name? #'sel-name) (let () - (unless (sel-name? #'sel-name) - (raise-syntax-error 'struct/dc not-field-name-str stx #'sel-name)) (for ([name (in-list (syntax->list #'(dep-name ...)))]) (unless (sel-name? name) (raise-syntax-error 'struct/dc not-field-name-str stx name))) @@ -668,6 +669,9 @@ [x (identifier? #'x) (combine struct-id id)] + [(#:selector sel-id) + (identifier? #'sel-id) + #'sel-id] [(sel-id #:parent parent-id) (combine #'parent-id #'sel-id)])) @@ -1069,7 +1073,7 @@ (string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) "")))) (cond [(free-identifier=? #'struct-name struct-id) - field-name] + #`(#:selector #,sel)] [else #`(#,field-name #:parent #,struct-id)])] [else #f])])] @@ -1085,8 +1089,8 @@ (do-struct/dc #t (with-syntax ([(fields ...) (for/list ([selector-id (in-list selector-ids)] - [i (in-naturals)]) - (selector-id->field selector-id i))]) + [i (in-naturals)]) + (selector-id->field selector-id i))]) #`(-struct/dc struct-name [fields args] ...))))] [(_ struct-name anything ...) (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 0d1ab33b49..336be3eb63 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -418,6 +418,7 @@ produced. Otherwise, an impersonator contract is produced. maybe-dep-state contract-expr]] [field-name field-id + (#:selector selector-id) (field-id #:parent struct-id)] [maybe-lazy (code:line) #:lazy] [maybe-flat-or-impersonator (code:line) #:flat #:impersonator] @@ -432,13 +433,19 @@ expression is evaluated each time a selector is applied, building a new contract for the fields based on the values of the @racket[dep-field-name] fields (the @racket[dep-field-name] syntax is the same as the @racket[field-name] syntax). If the field is a dependent field, then it is assumed that the contract is -a chaperone, but not always a flat contract (and theus the entire @racket[struct/dc] +a chaperone, but not always a flat contract (and thus the entire @racket[struct/dc] contract is not a flat contract). If this is not the case, and the contract is always flat then the field must be annotated with the @racket[#:flat], or the field must be annotated with @racket[#:chaperone] (in which case, it must be a mutable field). +A @racket[field-name] is either an identifier naming a field in the first +case, an identifier naming a selector in the second case indicated +by the @racket[#:selector] keyword, or +a field id for a struct that is a parent of @racket[struct-id], indicated +by the @racket[#:parent] keyword. + If the @racket[#:lazy] keyword appears, then the contract on the field is check lazily (only when a selector is applied); @racket[#:lazy] contracts cannot be put on mutable fields. diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index da5859324a..eee9b63b0a 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -14402,6 +14402,45 @@ so that propagation occurs. (eval '(require 'provide/contract42-m2)) (eval 'provide/contract42-x)) 10) + + (test/spec-passed/result + 'provide/contract43 + '(begin + (eval '(module provide/contract43-m1 racket/base + (require racket/contract) + (struct spider (legs)) + (provide (contract-out (struct spider ([legs number?])))))) + + (eval '(module provide/contract43-m2 racket/base + (require racket/contract 'provide/contract43-m1) + (provide provide/contract43-x) + (define provide/contract43-x + (spider-legs + (contract (struct/c spider integer?) + (spider 121) + 'pos + 'neg))))) + + (eval '(require 'provide/contract43-m2)) + (eval 'provide/contract43-x)) + 121) + + (test/spec-passed + 'provide/contract44 + '(begin + (eval '(module provide/contract44-m1 racket/base + (require racket/contract) + (struct heap (v) #:transparent) + (provide (rename-out (heap new-heap))))) + + (eval '(module provide/contract44-m2 racket/base + (require racket/contract 'provide/contract44-m1) + (contract (struct/c new-heap any/c) + (new-heap 121) + 'pos + 'neg))) + + (eval '(require 'provide/contract44-m2)))) (contract-error-test 'contract-error-test8