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

adjust struct/c so that it just expands into struct/dc

Browse Source
This commit is contained in:
Robby Findler 2012-05-11 22:07:31 -05:00
parent 93d8e89b66
commit 698c895413
5 changed files with 88 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/contract/base.rkt
View File

@ -6,7 +6,6 @@
"private/box.rkt" "private/box.rkt"
"private/hash.rkt" "private/hash.rkt"
"private/vector.rkt" "private/vector.rkt"
"private/struct.rkt"
"private/struct-dc.rkt" "private/struct-dc.rkt"
"private/struct-prop.rkt" "private/struct-prop.rkt"
"private/misc.rkt" "private/misc.rkt"
@ -31,7 +30,6 @@
"private/box.rkt" "private/box.rkt"
"private/hash.rkt" "private/hash.rkt"
"private/vector.rkt" "private/vector.rkt"
"private/struct.rkt"
"private/struct-dc.rkt" "private/struct-dc.rkt"
"private/struct-prop.rkt") "private/struct-prop.rkt")
(except-out (all-from-out "private/base.rkt") (except-out (all-from-out "private/base.rkt")

1
collects/racket/contract/private/opters.rkt
View File

@ -6,7 +6,6 @@
"blame.rkt" "blame.rkt"
"misc.rkt" "misc.rkt"
"arrow.rkt" "arrow.rkt"
"struct.rkt"
(for-syntax racket/base (for-syntax racket/base
syntax/stx syntax/stx
"opt-guts.rkt")) "opt-guts.rkt"))

79
collects/racket/contract/private/struct-dc.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(provide (rename-out [-struct/dc struct/dc])) (provide (rename-out [-struct/dc struct/dc])
struct/c)
(require (for-syntax racket/base (require (for-syntax racket/base
racket/list racket/list
@ -100,15 +101,21 @@
(define unique (box #f)) (define unique (box #f))
(define (struct/dc-name ctc) (define (struct/dc-name ctc)
`(struct/dc ,(base-struct/dc-name-info ctc) (define struct/c? (base-struct/dc-struct/c? ctc))
`(,(if struct/c?
'struct/c
'struct/dc)
,(base-struct/dc-name-info ctc)
,@(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]) ,@(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))])
(cond (cond
[(indep? subcontract) [(indep? subcontract)
(if struct/c?
(contract-name (indep-ctc subcontract))
`[,(subcontract-field-name subcontract) `[,(subcontract-field-name subcontract)
,@(if (lazy-immutable? subcontract) ,@(if (lazy-immutable? subcontract)
'(#:lazy) '(#:lazy)
'()) '())
,(contract-name (indep-ctc subcontract))]] ,(contract-name (indep-ctc subcontract))])]
[else [else
`[,(subcontract-field-name subcontract) `[,(subcontract-field-name subcontract)
,(dep-dep-names subcontract) ,(dep-dep-names subcontract)
@ -401,7 +408,7 @@
(dep-dep-proc that-subcontract)))] (dep-dep-proc that-subcontract)))]
[else #t])))) [else #t]))))
(define-struct base-struct/dc (subcontracts pred struct-name here name-info)) (define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?))
(define-struct (struct/dc base-struct/dc) () (define-struct (struct/dc base-struct/dc) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
@ -422,15 +429,15 @@
#:stronger struct/dc-stronger?))) #:stronger struct/dc-stronger?)))
(define-struct (impersonator-struct/dc base-struct/dc) () (define-struct (impersonator-struct/dc base-struct/dc) ()
#:property prop:flat-contract #:property prop:contract
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-flat-contract-property (build-contract-property
#:name struct/dc-name #:name struct/dc-name
#:first-order struct/dc-first-order #:first-order struct/dc-first-order
#:projection struct/dc-proj #:projection struct/dc-proj
#:stronger struct/dc-stronger?))) #:stronger struct/dc-stronger?)))
(define (build-struct/dc subcontracts pred struct-name here name-info) (define (build-struct/dc subcontracts pred struct-name here name-info struct/c?)
(for ([subcontract (in-list subcontracts)]) (for ([subcontract (in-list subcontracts)])
(when (and (indep? subcontract) (when (and (indep? subcontract)
(not (mutable? subcontract))) (not (mutable? subcontract)))
@ -442,18 +449,20 @@
(cond (cond
[(indep? subcontract) (flat-contract? (indep-ctc subcontract))] [(indep? subcontract) (flat-contract? (indep-ctc subcontract))]
[(dep? subcontract) (eq? '#:flat (dep-type subcontract))])) [(dep? subcontract) (eq? '#:flat (dep-type subcontract))]))
(define (impersonator-subcontract? subcontract) (define (impersonator-subcontract? subcontract)
(cond (cond
[(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))] [(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))]
[(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))])) [(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))]))
((cond ((cond
[(andmap flat-subcontract? subcontracts) [(and (andmap flat-subcontract? subcontracts)
(not (ormap subcontract-mutable-field? subcontracts)))
make-flat-struct/dc] make-flat-struct/dc]
[(ormap impersonator-subcontract? subcontracts) [(ormap impersonator-subcontract? subcontracts)
make-impersonator-struct/dc] make-impersonator-struct/dc]
[else [else
make-struct/dc]) make-struct/dc])
subcontracts pred struct-name here name-info)) subcontracts pred struct-name here name-info struct/c?))
(define-for-syntax (get-struct-info id stx) (define-for-syntax (get-struct-info id stx)
@ -635,7 +644,7 @@
(raise-syntax-error #f "found cyclic dependencies" (raise-syntax-error #f "found cyclic dependencies"
stx)))) stx))))
(define-syntax (-struct/dc stx) (define-for-syntax (do-struct/dc struct/c? stx)
(define-values (info struct-id clauses) (parse-struct/dc stx)) (define-values (info struct-id clauses) (parse-struct/dc stx))
(define sorted-clauses (top-sort/clauses stx clauses)) (define sorted-clauses (top-sort/clauses stx clauses))
@ -753,7 +762,10 @@
#,(list-ref info 2) #,(list-ref info 2)
'struct-id 'struct-id
(quote-module-name) (quote-module-name)
'#,struct-id)) '#,struct-id
#,struct/c?))
(define-syntax (-struct/dc stx) (do-struct/dc #f stx))
(define-for-syntax (traverse-no-neg-blame-identifiers no-neg-blame) (define-for-syntax (traverse-no-neg-blame-identifiers no-neg-blame)
(for/and ([id (in-list no-neg-blame)]) (for/and ([id (in-list no-neg-blame)])
@ -945,3 +957,48 @@
(raise-blame-error blame obj (raise-blame-error blame obj
"expected a struct of type ~a" "expected a struct of type ~a"
what)) what))
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(syntax/loc stx (#%expression x)))]))
(define-syntax (do-struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(let* ([si (extract-struct-info (syntax-local-value (syntax struct-name)))]
[predicate-id (third si)]
[selector-ids (reverse (fourth si))]
[mutator-ids (reverse (fifth si))]
[ctcs (syntax->list #'(args ...))]
[ctc-names (generate-temporaries #'(args ...))])
(unless (= (length selector-ids) (length ctcs))
(raise-syntax-error 'struct/c
(format "expected ~a contracts because struct ~a has ~a fields"
(length selector-ids)
(syntax-e #'struct-name)
(length selector-ids))
stx))
(unless predicate-id
(raise-syntax-error 'struct/c
(format "could not determine predicate for ~s" (syntax-e #'struct-name))
stx))
(unless (andmap values selector-ids)
(raise-syntax-error 'struct/c
(format "could not determine selectors for ~s" (syntax-e #'struct-name))
stx))
(define strip-reg (regexp (format "^~a-" (regexp-quote (symbol->string (syntax-e #'struct-name))))))
(define (selector-id->field sel)
(datum->syntax #'struct-name
(string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) ""))))
(do-struct/dc
#t
(with-syntax ([(fields ...) (map selector-id->field selector-ids)])
#`(-struct/dc struct-name [fields args] ...))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))

246
collects/racket/contract/private/struct.rkt
View File

@ -1,246 +0,0 @@
#lang racket/base
(require (for-syntax racket/base
racket/list
racket/struct-info
"opt-guts.rkt"
(only-in "ds-helpers.rkt" defeat-inlining))
syntax/location
racket/list
"guts.rkt"
"blame.rkt"
"prop.rkt"
"misc.rkt"
"opt.rkt")
(provide struct/c)
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(syntax/loc stx (#%expression x)))]))
;; name is symbol
;; predicate is (-> any bool)
;; immutables is (listof (list natural contract selector-proc))
;; mutables is (listof (list natural contract selector-proc mutator-proc))
(define-struct base-struct/c (name predicate immutables mutables))
(define (struct/c-name ctc)
(let ([ctcs (map second
(sort (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc))
< #:key first))])
(apply build-compound-type-name 'struct/c (base-struct/c-name ctc) ctcs)))
(define (check-struct/c ctc)
(let ([name (base-struct/c-name ctc)]
[pred? (base-struct/c-predicate ctc)]
[ctc/ref-pairs (map (λ (l) (cons (second l) (third l)))
(append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc)))])
(λ (val fail [first-order? #f])
(unless (pred? val)
(fail "expected: ~s, got ~e" name val))
(when first-order?
(for ([p (in-list ctc/ref-pairs)])
(let ([c (car p)] [v ((cdr p) val)])
(unless (contract-first-order-passes? c v)
(fail "expected: ~s, got ~e" (contract-name c) v)))))
#t)))
(define (struct/c-first-order ctc)
(let ([f (check-struct/c ctc)])
(λ (val)
(let/ec fail
(f val (λ args (fail #f)) #t)))))
(define (flat-struct/c-proj ctc)
(let ([checker (check-struct/c ctc)]
[name (base-struct/c-name ctc)]
[pred (base-struct/c-predicate ctc)]
[projs (map contract-projection (map second (base-struct/c-immutables ctc)))]
[refs (map third (base-struct/c-immutables ctc))])
(λ (blame)
(let ([pos-projs (map (λ (f) (f blame)) projs)])
(λ (val)
(checker val (λ args (apply raise-blame-error blame val args)))
(for ([p (in-list pos-projs)] [ref (in-list refs)])
(p (ref val)))
val)))))
(define-struct (flat-struct/c base-struct/c) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name struct/c-name
#:first-order struct/c-first-order
#:projection flat-struct/c-proj))
(define (chaperone-struct/c-proj ctc)
(let-values ([(flat-imms chap-imms)
(partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
(let ([checker (check-struct/c ctc)]
[name (base-struct/c-name ctc)]
[pred (base-struct/c-predicate ctc)]
[flat-imm-projs (map (compose contract-projection second) flat-imms)]
[flat-imm-refs (map third flat-imms)]
[chap-imm-projs (map (compose contract-projection second) chap-imms)]
[chap-imm-refs (map third chap-imms)]
[mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
[mut-refs (map third (base-struct/c-mutables ctc))]
[mut-sets (map fourth (base-struct/c-mutables ctc))])
(λ (blame)
(let* ([swapped-blame (blame-swap blame)]
[flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
[chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
[mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
[mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
(λ (val)
(checker val (λ args (apply raise-blame-error blame val args)))
(for ([p (in-list flat-imm-pos-projs)]
[ref (in-list flat-imm-refs)])
(p (ref val)))
;; While gathering up the selectors and the appropriate projections,
;; we go ahead and apply the projection to check the first order properties.
(let ([chaperone-args (list impersonator-prop:contracted ctc)])
;; combined-imm-refs
(for ([p (in-list chap-imm-pos-projs)]
[ref (in-list chap-imm-refs)])
(p (ref val))
(set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
;; combined-mut-refs
(for ([p (in-list mut-pos-projs)]
[ref (in-list mut-refs)])
(p (ref val))
(set! chaperone-args (list* ref (λ (s v) (p v)) chaperone-args)))
;; combined-mut-sets
(for ([p (in-list mut-neg-projs)]
[set (in-list mut-sets)])
(set! chaperone-args (list* set (λ (s v) (p v)) chaperone-args)))
(apply chaperone-struct val chaperone-args))))))))
(define-struct (chaperone-struct/c base-struct/c) ()
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:name struct/c-name
#:first-order struct/c-first-order
#:projection chaperone-struct/c-proj)))
(define (impersonator-struct/c-proj ctc)
(let-values ([(flat-imms chap-imms)
(partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
(let ([checker (check-struct/c ctc)]
[name (base-struct/c-name ctc)]
[pred (base-struct/c-predicate ctc)]
[flat-imm-projs (map (compose contract-projection second) flat-imms)]
[flat-imm-refs (map third flat-imms)]
[chap-imm-projs (map (compose contract-projection second) chap-imms)]
[chap-imm-refs (map third chap-imms)]
[mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
[mut-refs (map third (base-struct/c-mutables ctc))]
[mut-sets (map fourth (base-struct/c-mutables ctc))])
(λ (blame)
(let* ([swapped-blame (blame-swap blame)]
[flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
[chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
[mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
[mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
(λ (val)
(checker val (λ args (apply raise-blame-error blame val args)))
(for ([p (in-list flat-imm-pos-projs)]
[ref (in-list flat-imm-refs)])
(p (ref val)))
;; While gathering up the selectors and the appropriate projections,
;; we go ahead and apply the projection to check the first order properties.
(let ([combined-imm-refs
(for/list ([p (in-list chap-imm-pos-projs)]
[ref (in-list chap-imm-refs)])
(p (ref val))
(list ref (λ (s v) (p v))))]
[combined-mut-refs
(for/list ([p (in-list mut-pos-projs)]
[ref (in-list mut-refs)])
(p (ref val))
(list ref (λ (s v) (p v))))]
[combined-mut-sets
(for/list ([p (in-list mut-neg-projs)]
[set (in-list mut-sets)])
(list set (λ (s v) (p v))))])
(apply impersonate-struct
(apply chaperone-struct val
combined-imm-refs)
(flatten (list combined-mut-refs combined-mut-sets
impersonator-prop:contracted ctc))))))))))
(define-struct (impersonator-struct/c base-struct/c) ()
#:property prop:contract
(build-contract-property
#:name struct/c-name
#:first-order struct/c-first-order
#:projection impersonator-struct/c-proj))
(define-syntax (do-struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(let* ([si (extract-struct-info (syntax-local-value (syntax struct-name)))]
[predicate-id (third si)]
[selector-ids (reverse (fourth si))]
[mutator-ids (reverse (fifth si))]
[ctcs (syntax->list #'(args ...))]
[ctc-names (generate-temporaries #'(args ...))])
(unless (= (length selector-ids) (length ctcs))
(raise-syntax-error 'struct/c
(format "expected ~a contracts because struct ~a has ~a fields"
(length selector-ids)
(syntax-e #'struct-name)
(length selector-ids))
stx))
(unless predicate-id
(raise-syntax-error 'struct/c
(format "could not determine predicate for ~s" (syntax-e #'struct-name))
stx))
(unless (andmap values selector-ids)
(raise-syntax-error 'struct/c
(format "could not determine selectors for ~s" (syntax-e #'struct-name))
stx))
(let ([combined-ids (for/list ([n (in-naturals)]
[ctc-name (in-list ctc-names)]
[ref-name (in-list selector-ids)]
[mut-name (in-list mutator-ids)])
(list n ctc-name ref-name mut-name))])
(let-values ([(mutables immutables) (partition (λ (l) (fourth l)) combined-ids)])
(with-syntax ([(ctc-x ...) ctc-names]
[predicate-id predicate-id]
[((imm-count imm-ctc-x imm-ref _) ...) immutables]
[((mut-count mut-ctc-x mut-ref mut-set) ...) mutables])
(syntax
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
(let ([immutables (list (list imm-count imm-ctc-x imm-ref) ...)]
[mutables (list (list mut-count mut-ctc-x mut-ref mut-set) ...)])
(struct/c/proc 'struct-name predicate-id immutables mutables))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
(define (struct/c/proc struct-name predicate immutables mutables)
(for ([lst (in-list immutables)])
(define imm-count (list-ref lst 0))
(define imm-ctc (list-ref lst 1))
(unless (chaperone-contract? imm-ctc)
(error 'struct/c "expected a chaperone contract for immutable field ~v (counting from 0), got ~e"
imm-count imm-ctc)))
(cond
[(and (null? mutables) (andmap (λ (l) (flat-contract? (second l))) immutables))
(make-flat-struct/c struct-name predicate immutables mutables)]
[(andmap (λ (l) (chaperone-contract? (second l))) mutables)
(make-chaperone-struct/c struct-name predicate immutables mutables)]
[else
(make-impersonator-struct/c struct-name predicate immutables mutables)]))

3
collects/tests/racket/contract-test.rktl
View File

@ -10922,6 +10922,9 @@ so that propagation occurs.
(ctest #f flat-contract? (let () (ctest #f flat-contract? (let ()
(define-struct s (a b) #:mutable) (define-struct s (a b) #:mutable)
(struct/c s any/c any/c))) (struct/c s any/c any/c)))
(ctest #f flat-contract? (let ()
(define-struct s (a b) #:mutable)
(struct/c s any/c integer?)))
(ctest #t chaperone-contract? (let () (ctest #t chaperone-contract? (let ()
(define-struct s (a b) #:mutable) (define-struct s (a b) #:mutable)
(struct/c s any/c any/c))) (struct/c s any/c any/c)))