adjust struct/c so that it just expands into struct/dc
This commit is contained in:
Robby Findler
parent
93d8e89b66
commit
698c895413
|
|
@ -6,7 +6,6 @@
|
|||
"private/box.rkt"
|
||||
"private/hash.rkt"
|
||||
"private/vector.rkt"
|
||||
"private/struct.rkt"
|
||||
"private/struct-dc.rkt"
|
||||
"private/struct-prop.rkt"
|
||||
"private/misc.rkt"
|
||||
|
|
@ -31,7 +30,6 @@
|
|||
"private/box.rkt"
|
||||
"private/hash.rkt"
|
||||
"private/vector.rkt"
|
||||
"private/struct.rkt"
|
||||
"private/struct-dc.rkt"
|
||||
"private/struct-prop.rkt")
|
||||
(except-out (all-from-out "private/base.rkt")
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@
|
|||
"blame.rkt"
|
||||
"misc.rkt"
|
||||
"arrow.rkt"
|
||||
"struct.rkt"
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
"opt-guts.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (rename-out [-struct/dc struct/dc]))
|
||||
(provide (rename-out [-struct/dc struct/dc])
|
||||
struct/c)
|
||||
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
|
|
@ -100,25 +101,31 @@
|
|||
(define unique (box #f))
|
||||
|
||||
(define (struct/dc-name ctc)
|
||||
`(struct/dc ,(base-struct/dc-name-info ctc)
|
||||
,@(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))])
|
||||
(cond
|
||||
[(indep? subcontract)
|
||||
`[,(subcontract-field-name subcontract)
|
||||
,@(if (lazy-immutable? subcontract)
|
||||
'(#:lazy)
|
||||
'())
|
||||
,(contract-name (indep-ctc subcontract))]]
|
||||
[else
|
||||
`[,(subcontract-field-name subcontract)
|
||||
,(dep-dep-names subcontract)
|
||||
,@(if (dep-lazy-immutable? subcontract)
|
||||
'(#:lazy)
|
||||
'())
|
||||
,@(if (eq? '#:chaperone (dep-type subcontract))
|
||||
'()
|
||||
(list (dep-type subcontract)))
|
||||
...]]))))
|
||||
(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))])
|
||||
(cond
|
||||
[(indep? subcontract)
|
||||
(if struct/c?
|
||||
(contract-name (indep-ctc subcontract))
|
||||
`[,(subcontract-field-name subcontract)
|
||||
,@(if (lazy-immutable? subcontract)
|
||||
'(#:lazy)
|
||||
'())
|
||||
,(contract-name (indep-ctc subcontract))])]
|
||||
[else
|
||||
`[,(subcontract-field-name subcontract)
|
||||
,(dep-dep-names subcontract)
|
||||
,@(if (dep-lazy-immutable? subcontract)
|
||||
'(#:lazy)
|
||||
'())
|
||||
,@(if (eq? '#:chaperone (dep-type subcontract))
|
||||
'()
|
||||
(list (dep-type subcontract)))
|
||||
...]]))))
|
||||
|
||||
(define (struct/dc-first-order ctc)
|
||||
(base-struct/dc-pred ctc))
|
||||
|
|
@ -401,7 +408,7 @@
|
|||
(dep-dep-proc that-subcontract)))]
|
||||
[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) ()
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -422,15 +429,15 @@
|
|||
#:stronger struct/dc-stronger?)))
|
||||
|
||||
(define-struct (impersonator-struct/dc base-struct/dc) ()
|
||||
#:property prop:flat-contract
|
||||
#:property prop:contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-flat-contract-property
|
||||
(build-contract-property
|
||||
#:name struct/dc-name
|
||||
#:first-order struct/dc-first-order
|
||||
#:projection struct/dc-proj
|
||||
#: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)])
|
||||
(when (and (indep? subcontract)
|
||||
(not (mutable? subcontract)))
|
||||
|
|
@ -442,18 +449,20 @@
|
|||
(cond
|
||||
[(indep? subcontract) (flat-contract? (indep-ctc subcontract))]
|
||||
[(dep? subcontract) (eq? '#:flat (dep-type subcontract))]))
|
||||
|
||||
(define (impersonator-subcontract? subcontract)
|
||||
(cond
|
||||
[(indep? subcontract) (impersonator-contract? (indep-ctc subcontract))]
|
||||
[(dep? subcontract) (eq? '#:impersonator (dep-type subcontract))]))
|
||||
((cond
|
||||
[(andmap flat-subcontract? subcontracts)
|
||||
[(and (andmap flat-subcontract? subcontracts)
|
||||
(not (ormap subcontract-mutable-field? subcontracts)))
|
||||
make-flat-struct/dc]
|
||||
[(ormap impersonator-subcontract? subcontracts)
|
||||
make-impersonator-struct/dc]
|
||||
[else
|
||||
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)
|
||||
|
|
@ -635,7 +644,7 @@
|
|||
(raise-syntax-error #f "found cyclic dependencies"
|
||||
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 sorted-clauses (top-sort/clauses stx clauses))
|
||||
|
||||
|
|
@ -753,7 +762,10 @@
|
|||
#,(list-ref info 2)
|
||||
'struct-id
|
||||
(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)
|
||||
(for/and ([id (in-list no-neg-blame)])
|
||||
|
|
@ -945,3 +957,48 @@
|
|||
(raise-blame-error blame obj
|
||||
"expected a struct of type ~a"
|
||||
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))]))
|
||||
|
|
@ -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)]))
|
||||
|
||||
|
|
@ -10922,6 +10922,9 @@ so that propagation occurs.
|
|||
(ctest #f flat-contract? (let ()
|
||||
(define-struct s (a b) #:mutable)
|
||||
(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 ()
|
||||
(define-struct s (a b) #:mutable)
|
||||
(struct/c s any/c any/c)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user