Extend struct/c to allow impersonator contracts for mutable fields.
Also, flat contracts for immutable fields are only evaluated at contract wrapping time.
This commit is contained in:
Stevie Strickland
parent
4b89dde511
commit
5b8e5d6380
|
|
@ -1,105 +1,226 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base
|
||||
racket/struct-info
|
||||
"helpers.rkt")
|
||||
racket/list
|
||||
racket/struct-info)
|
||||
racket/list
|
||||
"guts.rkt")
|
||||
|
||||
(provide struct/c)
|
||||
|
||||
#|
|
||||
as with copy-struct in struct.rkt, this first begin0
|
||||
expansion "declares" that struct/c is an expression.
|
||||
It prevents further expansion until the internal definition
|
||||
context is sorted out.
|
||||
|#
|
||||
(define-syntax (struct/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
|
||||
(syntax/loc stx (begin0 x)))]))
|
||||
(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 <~a>, 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 <~a>, 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 ([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 chaperone-struct val
|
||||
(flatten (list combined-imm-refs combined-mut-refs combined-mut-sets
|
||||
impersonator-prop:contracted ctc))))))))))
|
||||
|
||||
(define-struct (chaperone-struct/c base-struct/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(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))))
|
||||
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-proj-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-pos-proj-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-neg-proj-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
|
||||
[(field-numbers ...)
|
||||
(let loop ([i 0]
|
||||
[l (syntax->list (syntax (args ...)))])
|
||||
(cond
|
||||
[(null? l) '()]
|
||||
[else (cons i (loop (+ i 1) (cdr l)))]))]
|
||||
[(type-desc-id
|
||||
constructor-id
|
||||
predicate-id
|
||||
(rev-selector-id ...)
|
||||
(rev-mutator-id ...)
|
||||
super-id)
|
||||
(lookup-struct-info (syntax struct-name) stx)])
|
||||
(unless (= (length (syntax->list (syntax (rev-selector-id ...))))
|
||||
(length (syntax->list (syntax (args ...)))))
|
||||
(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 (syntax->list (syntax (rev-selector-id ...))))
|
||||
(length selector-ids)
|
||||
(syntax-e #'struct-name)
|
||||
(length (syntax->list (syntax (rev-selector-id ...)))))
|
||||
(length selector-ids))
|
||||
stx))
|
||||
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]
|
||||
[(mutator-id ...) (reverse (syntax->list (syntax (rev-mutator-id ...))))])
|
||||
(syntax
|
||||
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
|
||||
|
||||
(unless predicate-id
|
||||
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
|
||||
(unless (and selector-id ...)
|
||||
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
|
||||
(unless (chaperone-contract? ctc-x)
|
||||
(error 'struct/c "expected chaperone contracts as arguments, got ~e" args))
|
||||
...
|
||||
|
||||
(let* ([ctc-pred-x (contract-first-order ctc-x)]
|
||||
...
|
||||
[ctc-name-x (contract-name ctc-x)]
|
||||
...
|
||||
;; To have a flat contract result, all of the contracted fields must be immutable
|
||||
;; and all the contracts must be flat.
|
||||
[flat? (and (andmap not (list mutator-id ...))
|
||||
(for/and ([c (in-list (list ctc-x ...))])
|
||||
(flat-contract? c)))]
|
||||
[fo-check (λ (val)
|
||||
(and (predicate-id val)
|
||||
(ctc-pred-x (selector-id val)) ...))])
|
||||
(if flat?
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
|
||||
fo-check)
|
||||
(make-chaperone-contract
|
||||
#:name (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
|
||||
#:first-order fo-check
|
||||
#:projection
|
||||
(let ([ctc-proj-x (contract-projection ctc-x)] ...)
|
||||
(λ (blame)
|
||||
(let* ([swapped-blame (blame-swap blame)]
|
||||
[ctc-pos-proj-x (ctc-proj-x blame)] ...
|
||||
[ctc-neg-proj-x (ctc-proj-x swapped-blame)] ...)
|
||||
(λ (val)
|
||||
(unless (predicate-id val)
|
||||
(raise-blame-error blame val "expected a <~a>, got ~v" struct-name val))
|
||||
;; Do first order checks on values in case the struct doesn't adhere to them
|
||||
;; at wrapping time
|
||||
(ctc-pos-proj-x (selector-id val)) ...
|
||||
(apply chaperone-struct val
|
||||
(append (list* selector-id (λ (s v) (ctc-pos-proj-x v))
|
||||
(if mutator-id
|
||||
(list mutator-id (λ (s v) (ctc-neg-proj-x v)))
|
||||
null)) ...)))))))))))))]
|
||||
(unless predicate-id
|
||||
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
|
||||
(unless (andmap values selector-ids)
|
||||
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
|
||||
|
||||
(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)] ...)
|
||||
|
||||
(unless (chaperone-contract? imm-ctc-x)
|
||||
(error 'struct/c "expected a chaperone contract for immutable field ~v, got ~e"
|
||||
imm-count imm-ctc-x))
|
||||
...
|
||||
|
||||
(let ([immutables (list (list imm-count imm-ctc-x imm-ref) ...)]
|
||||
[mutables (list (list mut-count mut-ctc-x mut-ref mut-set) ...)])
|
||||
(cond
|
||||
[(and (null? mutables) (andmap (λ (l) (flat-contract? (second l))) immutables))
|
||||
(make-flat-struct/c 'struct-name predicate-id immutables mutables)]
|
||||
[(andmap (λ (l) (chaperone-contract? (second l))) mutables)
|
||||
(make-chaperone-struct/c 'struct-name predicate-id immutables mutables)]
|
||||
[else
|
||||
(make-impersonator-struct/c 'struct-name predicate-id immutables mutables)]))))))))]
|
||||
[(_ struct-name anything ...)
|
||||
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
|
||||
|
|
|
|||
|
|
@ -345,15 +345,17 @@ Produces a flat contract that recognizes syntax objects whose
|
|||
@racket[syntax-e] content matches @racket[c].}
|
||||
|
||||
|
||||
@defform[(struct/c struct-id chaperone-contract-expr ...)]{
|
||||
|
||||
@defform[(struct/c struct-id contract-expr ...)]{
|
||||
Produces a contract that recognizes instances of the structure
|
||||
type named by @racket[struct-id], and whose field values match the
|
||||
chaperone contracts produced by the @racket[chaperone-contract-expr]s.
|
||||
contracts produced by the @racket[contract-expr]s.
|
||||
|
||||
If the fields are immutable and the @racket[chaperone-contract-expr]s evaluate
|
||||
to flat contracts, a flat contract is produced. Otherwise, a chaperone
|
||||
contract is produced.}
|
||||
Contracts for immutable fields must be either flat or chaperone contracts.
|
||||
Contracts for mutable fields may be impersonator contracts.
|
||||
If all fields are immutable and the @racket[contract-expr]s evaluate
|
||||
to flat contracts, a flat contract is produced. If all the
|
||||
@racket[contract-expr]s are chaperone contracts, a chaperone contract is
|
||||
produced. Otherwise, an impersonator contract is produced.}
|
||||
|
||||
|
||||
@defproc[(parameter/c [c contract?]) contract?]{
|
||||
|
|
|
|||
|
|
@ -8007,6 +8007,26 @@
|
|||
'pos
|
||||
'neg)])
|
||||
(set-s-b! v 5))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/c12
|
||||
'(let ()
|
||||
(define-struct s (a) #:mutable)
|
||||
(define alpha (new-∃/c 'alpha))
|
||||
(define v (make-s 3))
|
||||
(let ([v* (contract (struct/c s alpha) v 'pos 'neg)])
|
||||
(set-s-a! v* (s-a v*)))
|
||||
(s-a v))
|
||||
3)
|
||||
|
||||
(test/neg-blame
|
||||
'struct/c13
|
||||
'(let ()
|
||||
(define-struct s (a) #:mutable)
|
||||
(define alpha (new-∃/c 'alpha))
|
||||
(define v (make-s 3))
|
||||
(let ([v* (contract (struct/c s alpha) v 'pos 'neg)])
|
||||
(set-s-a! v* 4))))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -8980,19 +9000,44 @@ so that propagation occurs.
|
|||
(ctest #t flat-contract? (let ()
|
||||
(define-struct s (a b))
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s (a b) #:mutable)
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(define-struct s (a b) #:mutable)
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s ([a #:mutable] b))
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(define-struct s ([a #:mutable] b))
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s (a [b #:mutable]))
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(define-struct s (a [b #:mutable]))
|
||||
(struct/c s any/c any/c)))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s (f))
|
||||
(struct/c s (-> number? any))))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(define-struct s (f))
|
||||
(struct/c s (-> number? any))))
|
||||
|
||||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s (a) #:mutable)
|
||||
(define alpha (new-∃/c 'alpha))
|
||||
(struct/c s alpha)))
|
||||
(ctest #f chaperone-contract? (let ()
|
||||
(define-struct s (a) #:mutable)
|
||||
(define alpha (new-∃/c 'alpha))
|
||||
(struct/c s alpha)))
|
||||
(ctest #t contract? (let ()
|
||||
(define-struct s (a) #:mutable)
|
||||
(define alpha (new-∃/c 'alpha))
|
||||
(struct/c s alpha)))
|
||||
|
||||
;; Hash contracts with flat domain/range contracts
|
||||
(ctest #t contract? (hash/c any/c any/c #:immutable #f))
|
||||
(ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user