added contract-struct (like define-contract-struct, but with a
maker whose name does not begin with 'make-')
This commit is contained in:
Robby Findler
parent
ae1304789d
commit
367779fd27
|
|
@ -40,7 +40,8 @@
|
|||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.rkt")
|
||||
(except-out (all-from-out racket/contract/private/ds)
|
||||
lazy-depth-to-look)
|
||||
lazy-depth-to-look
|
||||
contract-struct)
|
||||
|
||||
(all-from-out racket/contract/private/base)
|
||||
(all-from-out racket/contract/private/provide)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,10 @@
|
|||
build-func-params
|
||||
build-clauses
|
||||
build-enforcer-clauses
|
||||
generate-arglists)
|
||||
generate-arglists
|
||||
(struct-out contract-struct-transformer))
|
||||
|
||||
(require "opt-guts.rkt")
|
||||
(require racket/struct-info "opt-guts.rkt")
|
||||
(require (for-template racket/base))
|
||||
|
||||
#|
|
||||
|
|
@ -382,3 +383,7 @@ which are then called when the contract's fields are explored
|
|||
(for-each
|
||||
(λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id)))
|
||||
(syntax->list (syntax (id ...))))]))
|
||||
|
||||
(struct contract-struct-transformer (info proc)
|
||||
#:property prop:struct-info (λ (ctc) (contract-struct-transformer-info ctc))
|
||||
#:property prop:procedure 1)
|
||||
|
|
@ -25,6 +25,7 @@ it around flattened out.
|
|||
(for-syntax "opt-guts.rkt"))
|
||||
|
||||
(provide define-contract-struct
|
||||
contract-struct
|
||||
|
||||
make-opt-contract/info
|
||||
;set-opt-contract/info-enforcer!
|
||||
|
|
@ -36,300 +37,312 @@ it around flattened out.
|
|||
unknown?
|
||||
synthesized-value)
|
||||
|
||||
(define-syntax (define-contract-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (fields ...))
|
||||
(syntax (define-contract-struct name (fields ...) (current-inspector)))]
|
||||
[(_ name (fields ...) inspector)
|
||||
(and (identifier? (syntax name))
|
||||
(andmap identifier? (syntax->list (syntax (fields ...)))))
|
||||
(let* ([mutable? (syntax-e (syntax mutable?))]
|
||||
[add-suffix
|
||||
(λ (suffix)
|
||||
(datum->syntax (syntax name)
|
||||
(string->symbol
|
||||
(string-append (symbol->string (syntax-e (syntax name)))
|
||||
suffix))
|
||||
stx))]
|
||||
[struct-names (build-struct-names (syntax name)
|
||||
(syntax->list (syntax (fields ...)))
|
||||
#f
|
||||
#t
|
||||
stx)]
|
||||
[struct:-name/val (list-ref struct-names 0)]
|
||||
[struct-maker/val (list-ref struct-names 1)]
|
||||
[predicate/val (list-ref struct-names 2)]
|
||||
[selectors/val (cdddr struct-names)]
|
||||
[struct/c-name/val (add-suffix "/c")]
|
||||
[struct/dc-name/val (add-suffix "/dc")]
|
||||
[field-count/val (length selectors/val)]
|
||||
[f-x/vals (generate-temporaries (syntax (fields ...)))]
|
||||
[f-xs/vals (generate-arglists f-x/vals)])
|
||||
|
||||
(with-syntax ([struct/c struct/c-name/val]
|
||||
[struct/dc struct/dc-name/val]
|
||||
[field-count field-count/val]
|
||||
[(selectors ...) selectors/val]
|
||||
[struct:-name struct:-name/val]
|
||||
[struct-maker struct-maker/val]
|
||||
[predicate predicate/val]
|
||||
[the-contract (add-suffix "-contract")]
|
||||
[(selector-indices ...) (nums-up-to field-count/val)]
|
||||
[(selector-indices+1 ...) (map add1 (nums-up-to field-count/val))]
|
||||
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
|
||||
[(f-x ...) f-x/vals]
|
||||
[((f-xs ...) ...) f-xs/vals]
|
||||
[wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))]
|
||||
[opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))])
|
||||
#`
|
||||
(begin
|
||||
|
||||
;; `declare' future bindings for the top-level (so that everyone picks them up)
|
||||
#,@(if (eq? (syntax-local-context) 'top-level)
|
||||
(list
|
||||
(syntax
|
||||
(define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set
|
||||
already-there? burrow-in rewrite-fields wrap-get)
|
||||
(values))))
|
||||
(list))
|
||||
|
||||
(define-syntax name (list #'struct:-name
|
||||
#'struct-maker
|
||||
#'predicate
|
||||
(reverse (list #'selectors ...))
|
||||
(list #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
|
||||
#t))
|
||||
|
||||
(define (evaluate-attrs stct contract/info)
|
||||
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes
|
||||
(let* ([any-unknown? #f]
|
||||
[any-became-known? #f]
|
||||
[synth-info (wrap-parent-get stct 0)]
|
||||
[ht (synth-info-vals synth-info)])
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (unknown? v)
|
||||
(let ([proc (unknown-proc v)])
|
||||
(let ([new (proc (wrap-get stct selector-indices+1) ...)])
|
||||
(cond
|
||||
[(unknown? new)
|
||||
(set! any-unknown? #t)]
|
||||
[else
|
||||
(set! any-became-known? #t)
|
||||
(hash-set! ht k new)]))))))
|
||||
(unless any-unknown?
|
||||
(check-synth-info-test stct synth-info contract/info))
|
||||
(when any-became-known?
|
||||
(for-each
|
||||
(lambda (x) ((evaluate-attr-prop-accessor x) x contract/info))
|
||||
(synth-info-parents synth-info)))
|
||||
(unless any-unknown?
|
||||
(set-synth-info-parents! synth-info '())))))
|
||||
|
||||
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
|
||||
(make-struct-type 'wrap-name
|
||||
wrap-parent-type ;; super struct
|
||||
2 ;; field count
|
||||
(max 0 (- field-count 1)) ;; auto-field-k
|
||||
#f ;; auto-field-v
|
||||
(list (cons evaluate-attr-prop evaluate-attrs))
|
||||
inspector))
|
||||
|
||||
(define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set)
|
||||
(make-struct-type 'opt-wrap-name
|
||||
#f ;; super struct
|
||||
2 ;; field count
|
||||
(+ 1 field-count) ;; auto-field-k
|
||||
#f ;; auto-field-v
|
||||
'() ;; prop-value-list
|
||||
inspector))
|
||||
|
||||
(define-values (type struct-maker raw-predicate get set)
|
||||
(make-struct-type 'name
|
||||
#f ;; super struct
|
||||
field-count
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
'() ;; prop-value-list
|
||||
inspector))
|
||||
|
||||
(define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x)))
|
||||
|
||||
(define-syntax (struct/dc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ clause (... ...))
|
||||
(with-syntax ([((maker-args (... ...))
|
||||
(names (... ...)))
|
||||
(build-clauses 'struct/dc
|
||||
(syntax coerce-contract)
|
||||
stx
|
||||
(syntax (clause (... ...))))])
|
||||
(syntax
|
||||
(let ([names 'names] (... ...))
|
||||
(contract-maker maker-args (... ...)))))]))
|
||||
|
||||
(define (do-selection stct i+1)
|
||||
(let-values ([(stct fields ...)
|
||||
(let loop ([stct stct])
|
||||
(cond
|
||||
[(raw-predicate stct)
|
||||
;; found the original value
|
||||
(values #f (get stct selector-indices) ...)]
|
||||
;; main : syntax syntax[list-of-identifier] syntax boolean -> syntax
|
||||
;; define-struct? tells us if this is a 'contract-struct' or a 'define-contract-struct'
|
||||
(define-for-syntax (main stx name fields inspector define-struct?)
|
||||
(with-syntax ([name name]
|
||||
[(fields ...) fields]
|
||||
[inspector inspector])
|
||||
|
||||
(let* ([mutable? (syntax-e (syntax mutable?))]
|
||||
[add-suffix
|
||||
(λ (suffix)
|
||||
(datum->syntax (syntax name)
|
||||
(string->symbol
|
||||
(string-append (symbol->string (syntax-e (syntax name)))
|
||||
suffix))
|
||||
stx))]
|
||||
[struct-names (build-struct-names (syntax name)
|
||||
(syntax->list (syntax (fields ...)))
|
||||
#f
|
||||
#t
|
||||
stx)]
|
||||
[struct:-name/val (list-ref struct-names 0)]
|
||||
[struct-maker/val (list-ref struct-names 1)]
|
||||
[predicate/val (list-ref struct-names 2)]
|
||||
[selectors/val (cdddr struct-names)]
|
||||
[struct/c-name/val (add-suffix "/c")]
|
||||
[struct/dc-name/val (add-suffix "/dc")]
|
||||
[field-count/val (length selectors/val)]
|
||||
[f-x/vals (generate-temporaries (syntax (fields ...)))]
|
||||
[f-xs/vals (generate-arglists f-x/vals)])
|
||||
|
||||
(with-syntax ([struct/c struct/c-name/val]
|
||||
[struct/dc struct/dc-name/val]
|
||||
[field-count field-count/val]
|
||||
[(selectors ...) selectors/val]
|
||||
[struct:-name struct:-name/val]
|
||||
[struct-maker struct-maker/val]
|
||||
[predicate predicate/val]
|
||||
[the-contract (add-suffix "-contract")]
|
||||
[(selector-indices ...) (nums-up-to field-count/val)]
|
||||
[(selector-indices+1 ...) (map add1 (nums-up-to field-count/val))]
|
||||
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
|
||||
[(f-x ...) f-x/vals]
|
||||
[((f-xs ...) ...) f-xs/vals]
|
||||
[wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))]
|
||||
[opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))])
|
||||
#`
|
||||
(begin
|
||||
|
||||
;; `declare' future bindings for the top-level (so that everyone picks them up)
|
||||
#,@(if (eq? (syntax-local-context) 'top-level)
|
||||
(list
|
||||
(syntax
|
||||
(define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set
|
||||
already-there? burrow-in rewrite-fields wrap-get)
|
||||
(values))))
|
||||
(list))
|
||||
|
||||
(define-syntax name
|
||||
#,(let ([the-info-list
|
||||
#`(list #'struct:-name
|
||||
#'struct-maker
|
||||
#'predicate
|
||||
(reverse (list #'selectors ...))
|
||||
(list #,@(map (λ (x) #f) (syntax->list #'(selectors ...))))
|
||||
#t)])
|
||||
(if define-struct?
|
||||
the-info-list
|
||||
#`(contract-struct-transformer #,the-info-list
|
||||
(λ (stx)
|
||||
(if (identifier? stx)
|
||||
#'struct-maker
|
||||
(let ([pr (syntax-e stx)])
|
||||
(if (pair? pr)
|
||||
(datum->syntax #'here (cons #'struct-maker (cdr pr)))
|
||||
(raise-syntax-error #f "what happened?" stx)))))))))
|
||||
|
||||
(define (evaluate-attrs stct contract/info)
|
||||
(when (wrap-parent-get stct 0) ;; test to make sure this even has attributes
|
||||
(let* ([any-unknown? #f]
|
||||
[any-became-known? #f]
|
||||
[synth-info (wrap-parent-get stct 0)]
|
||||
[ht (synth-info-vals synth-info)])
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(when (unknown? v)
|
||||
(let ([proc (unknown-proc v)])
|
||||
(let ([new (proc (wrap-get stct selector-indices+1) ...)])
|
||||
(cond
|
||||
[(unknown? new)
|
||||
(set! any-unknown? #t)]
|
||||
[else
|
||||
(set! any-became-known? #t)
|
||||
(hash-set! ht k new)]))))))
|
||||
(unless any-unknown?
|
||||
(check-synth-info-test stct synth-info contract/info))
|
||||
(when any-became-known?
|
||||
(for-each
|
||||
(lambda (x) ((evaluate-attr-prop-accessor x) x contract/info))
|
||||
(synth-info-parents synth-info)))
|
||||
(unless any-unknown?
|
||||
(set-synth-info-parents! synth-info '())))))
|
||||
|
||||
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
|
||||
(make-struct-type 'wrap-name
|
||||
wrap-parent-type ;; super struct
|
||||
2 ;; field count
|
||||
(max 0 (- field-count 1)) ;; auto-field-k
|
||||
#f ;; auto-field-v
|
||||
(list (cons evaluate-attr-prop evaluate-attrs))
|
||||
inspector))
|
||||
|
||||
(define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set)
|
||||
(make-struct-type 'opt-wrap-name
|
||||
#f ;; super struct
|
||||
2 ;; field count
|
||||
(+ 1 field-count) ;; auto-field-k
|
||||
#f ;; auto-field-v
|
||||
'() ;; prop-value-list
|
||||
inspector))
|
||||
|
||||
(define-values (type struct-maker raw-predicate get set)
|
||||
(make-struct-type 'name
|
||||
#f ;; super struct
|
||||
field-count
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
'() ;; prop-value-list
|
||||
inspector))
|
||||
|
||||
(define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x)))
|
||||
|
||||
(define-syntax (struct/dc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ clause (... ...))
|
||||
(with-syntax ([((maker-args (... ...))
|
||||
(names (... ...)))
|
||||
(build-clauses 'struct/dc
|
||||
(syntax coerce-contract)
|
||||
stx
|
||||
(syntax (clause (... ...))))])
|
||||
(syntax
|
||||
(let ([names 'names] (... ...))
|
||||
(contract-maker maker-args (... ...)))))]))
|
||||
|
||||
(define (do-selection stct i+1)
|
||||
(let-values ([(stct fields ...)
|
||||
(let loop ([stct stct])
|
||||
(cond
|
||||
[(raw-predicate stct)
|
||||
;; found the original value
|
||||
(values #f (get stct selector-indices) ...)]
|
||||
|
||||
[(opt-wrap-predicate stct)
|
||||
(let ((inner (opt-wrap-get stct 0)))
|
||||
(if inner
|
||||
(let* ((info (opt-wrap-get stct 1))
|
||||
(enforcer (opt-contract/info-enforcer info)))
|
||||
(let-values ([(inner-stct fields ...) (loop inner)])
|
||||
(let-values ([(fields ...) (enforcer stct fields ...)])
|
||||
(opt-wrap-set stct 0 #f)
|
||||
(opt-wrap-set stct selector-indices+1 fields) ...
|
||||
(values stct fields ...))))
|
||||
|
||||
;; found a cached version
|
||||
(values #f (opt-wrap-get stct selector-indices+1) ...)))]
|
||||
[(wrap-predicate stct)
|
||||
(let ([inner (wrap-get stct 0)])
|
||||
(if inner
|
||||
;; we have a contract to update
|
||||
(let ([contract/info (wrap-get stct 1)])
|
||||
(let-values ([(_1 fields ...) (loop inner)])
|
||||
(let-values ([(fields ...)
|
||||
(rewrite-fields stct contract/info fields ...)])
|
||||
(wrap-set stct 0 #f)
|
||||
(wrap-set stct selector-indices+1 fields) ...
|
||||
(evaluate-attrs stct contract/info)
|
||||
(values stct fields ...))))
|
||||
|
||||
;; found a cached version of the value
|
||||
(values #f (wrap-get stct selector-indices+1) ...)))]))])
|
||||
(cond
|
||||
[(opt-wrap-predicate stct) (opt-wrap-get stct i+1)]
|
||||
[(wrap-predicate stct) (wrap-get stct i+1)])))
|
||||
|
||||
(define (rewrite-fields parent contract/info ctc-x ...)
|
||||
(let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info)
|
||||
selector-indices)]
|
||||
[ctc (if (contract-struct? ctc-field)
|
||||
ctc-field
|
||||
(ctc-field f-xs ...))]
|
||||
|
||||
[(opt-wrap-predicate stct)
|
||||
(let ((inner (opt-wrap-get stct 0)))
|
||||
(if inner
|
||||
(let* ((info (opt-wrap-get stct 1))
|
||||
(enforcer (opt-contract/info-enforcer info)))
|
||||
(let-values ([(inner-stct fields ...) (loop inner)])
|
||||
(let-values ([(fields ...) (enforcer stct fields ...)])
|
||||
(opt-wrap-set stct 0 #f)
|
||||
(opt-wrap-set stct selector-indices+1 fields) ...
|
||||
(values stct fields ...))))
|
||||
|
||||
;; found a cached version
|
||||
(values #f (opt-wrap-get stct selector-indices+1) ...)))]
|
||||
[(wrap-predicate stct)
|
||||
(let ([inner (wrap-get stct 0)])
|
||||
(if inner
|
||||
;; we have a contract to update
|
||||
(let ([contract/info (wrap-get stct 1)])
|
||||
(let-values ([(_1 fields ...) (loop inner)])
|
||||
(let-values ([(fields ...)
|
||||
(rewrite-fields stct contract/info fields ...)])
|
||||
(wrap-set stct 0 #f)
|
||||
(wrap-set stct selector-indices+1 fields) ...
|
||||
(evaluate-attrs stct contract/info)
|
||||
(values stct fields ...))))
|
||||
|
||||
;; found a cached version of the value
|
||||
(values #f (wrap-get stct selector-indices+1) ...)))]))])
|
||||
(cond
|
||||
[(opt-wrap-predicate stct) (opt-wrap-get stct i+1)]
|
||||
[(wrap-predicate stct) (wrap-get stct i+1)])))
|
||||
|
||||
(define (rewrite-fields parent contract/info ctc-x ...)
|
||||
(let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info)
|
||||
selector-indices)]
|
||||
[ctc (if (contract-struct? ctc-field)
|
||||
ctc-field
|
||||
(ctc-field f-xs ...))]
|
||||
|
||||
[ctc-field-val
|
||||
(((contract-projection ctc)
|
||||
(contract/info-blame contract/info))
|
||||
ctc-x)])
|
||||
(update-parent-links parent ctc-field-val)
|
||||
ctc-field-val)] ...)
|
||||
(values f-x ...)))
|
||||
|
||||
(define (stronger-lazy-contract? a b)
|
||||
(and (contract-predicate b)
|
||||
(contract-stronger?
|
||||
(contract-get a selector-indices)
|
||||
(contract-get b selector-indices)) ...))
|
||||
|
||||
(define (lazy-contract-proj ctc)
|
||||
(λ (blame)
|
||||
(let ([contract/info (make-contract/info ctc blame)])
|
||||
(λ (val)
|
||||
(unless (or (wrap-predicate val)
|
||||
(opt-wrap-predicate val)
|
||||
(raw-predicate val))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <~a>, got ~e" 'name val))
|
||||
(cond
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
[else
|
||||
(let ([wrapper (wrap-maker val contract/info)])
|
||||
(let ([synth-setup-stuff (contract-get ctc field-count)])
|
||||
(when synth-setup-stuff
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (λ (pr) (hash-set! ht (car pr) (make-unknown (cdr pr))))
|
||||
(cdr synth-setup-stuff))
|
||||
(wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff))))))
|
||||
wrapper)])))))
|
||||
|
||||
(define (already-there? new-contract/info val depth)
|
||||
(cond
|
||||
[(raw-predicate val) #f]
|
||||
[(zero? depth) #f]
|
||||
[(wrap-predicate val)
|
||||
(and (wrap-get val 0)
|
||||
(let ([old-contract/info (wrap-get val 1)])
|
||||
(if (and (equal? (contract/info-blame new-contract/info)
|
||||
(contract/info-blame old-contract/info))
|
||||
(contract-stronger? (contract/info-contract old-contract/info)
|
||||
(contract/info-contract new-contract/info)))
|
||||
#t
|
||||
(already-there? new-contract/info (wrap-get val 0) (- depth 1)))))]
|
||||
[else
|
||||
;; when the zeroth field is cleared out, we don't
|
||||
;; have a contract to compare to anymore.
|
||||
#f]))
|
||||
|
||||
(define (struct/c ctc-x ...)
|
||||
(let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...)
|
||||
(contract-maker ctc-x ... #f)))
|
||||
|
||||
(define (selectors x)
|
||||
(burrow-in x 'selectors selector-indices))
|
||||
...
|
||||
|
||||
(define (burrow-in struct selector-name i)
|
||||
(cond
|
||||
[ctc-field-val
|
||||
(((contract-projection ctc)
|
||||
(contract/info-blame contract/info))
|
||||
ctc-x)])
|
||||
(update-parent-links parent ctc-field-val)
|
||||
ctc-field-val)] ...)
|
||||
(values f-x ...)))
|
||||
|
||||
(define (stronger-lazy-contract? a b)
|
||||
(and (contract-predicate b)
|
||||
(contract-stronger?
|
||||
(contract-get a selector-indices)
|
||||
(contract-get b selector-indices)) ...))
|
||||
|
||||
(define (lazy-contract-proj ctc)
|
||||
(λ (blame)
|
||||
(let ([contract/info (make-contract/info ctc blame)])
|
||||
(λ (val)
|
||||
(unless (or (wrap-predicate val)
|
||||
(opt-wrap-predicate val)
|
||||
(raw-predicate val))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <~a>, got ~e" 'name val))
|
||||
(cond
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
[else
|
||||
(let ([wrapper (wrap-maker val contract/info)])
|
||||
(let ([synth-setup-stuff (contract-get ctc field-count)])
|
||||
(when synth-setup-stuff
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (λ (pr) (hash-set! ht (car pr) (make-unknown (cdr pr))))
|
||||
(cdr synth-setup-stuff))
|
||||
(wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff))))))
|
||||
wrapper)])))))
|
||||
|
||||
(define (already-there? new-contract/info val depth)
|
||||
(cond
|
||||
[(raw-predicate val) #f]
|
||||
[(zero? depth) #f]
|
||||
[(wrap-predicate val)
|
||||
(and (wrap-get val 0)
|
||||
(let ([old-contract/info (wrap-get val 1)])
|
||||
(if (and (equal? (contract/info-blame new-contract/info)
|
||||
(contract/info-blame old-contract/info))
|
||||
(contract-stronger? (contract/info-contract old-contract/info)
|
||||
(contract/info-contract new-contract/info)))
|
||||
#t
|
||||
(already-there? new-contract/info (wrap-get val 0) (- depth 1)))))]
|
||||
[else
|
||||
;; when the zeroth field is cleared out, we don't
|
||||
;; have a contract to compare to anymore.
|
||||
#f]))
|
||||
|
||||
(define (struct/c ctc-x ...)
|
||||
(let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...)
|
||||
(contract-maker ctc-x ... #f)))
|
||||
|
||||
(define (selectors x)
|
||||
(burrow-in x 'selectors selector-indices))
|
||||
...
|
||||
|
||||
(define (burrow-in struct selector-name i)
|
||||
(cond
|
||||
[(raw-predicate struct)
|
||||
(get struct i)]
|
||||
[(opt-wrap-predicate struct)
|
||||
(if (opt-wrap-get struct 0)
|
||||
(do-selection struct (+ i 1))
|
||||
(opt-wrap-get struct (+ i 1)))]
|
||||
(do-selection struct (+ i 1))
|
||||
(opt-wrap-get struct (+ i 1)))]
|
||||
[(wrap-predicate struct)
|
||||
(if (wrap-get struct 0)
|
||||
(do-selection struct (+ i 1))
|
||||
(wrap-get struct (+ i 1)))]
|
||||
(do-selection struct (+ i 1))
|
||||
(wrap-get struct (+ i 1)))]
|
||||
[else
|
||||
(error selector-name "expected <~a>, got ~e" 'name struct)]))
|
||||
|
||||
(define (lazy-contract-name ctc)
|
||||
(do-contract-name 'struct/c
|
||||
'struct/dc
|
||||
(list (contract-get ctc selector-indices) ...)
|
||||
'(fields ...)
|
||||
(contract-get ctc field-count)))
|
||||
|
||||
(define lazy-contract-property
|
||||
(build-contract-property
|
||||
#:projection lazy-contract-proj
|
||||
#:name lazy-contract-name
|
||||
#:first-order (lambda (ctc) predicate)
|
||||
#:stronger stronger-lazy-contract?))
|
||||
|
||||
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
|
||||
(make-struct-type 'the-contract
|
||||
#f
|
||||
(+ field-count 1) ;; extra field is for synthesized attribute ctcs
|
||||
;; it is a list whose first element is
|
||||
;; a procedure (called once the attrs are known) that
|
||||
;; indicates if the test passes. the rest of the elements are
|
||||
;; procedures that build the attrs
|
||||
;; this field is #f when there is no synthesized attrs
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
(list (cons prop:contract lazy-contract-property))))
|
||||
|
||||
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses
|
||||
helper-id-var helper-info helper-freev
|
||||
enforcer-id-var)
|
||||
(define (make-free-vars free-vars freev)
|
||||
(let loop ([i 0]
|
||||
[stx null]
|
||||
[free-vars free-vars])
|
||||
(cond
|
||||
|
||||
(define (lazy-contract-name ctc)
|
||||
(do-contract-name 'struct/c
|
||||
'struct/dc
|
||||
(list (contract-get ctc selector-indices) ...)
|
||||
'(fields ...)
|
||||
(contract-get ctc field-count)))
|
||||
|
||||
(define lazy-contract-property
|
||||
(build-contract-property
|
||||
#:projection lazy-contract-proj
|
||||
#:name lazy-contract-name
|
||||
#:first-order (lambda (ctc) predicate)
|
||||
#:stronger stronger-lazy-contract?))
|
||||
|
||||
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
|
||||
(make-struct-type 'the-contract
|
||||
#f
|
||||
(+ field-count 1) ;; extra field is for synthesized attribute ctcs
|
||||
;; it is a list whose first element is
|
||||
;; a procedure (called once the attrs are known) that
|
||||
;; indicates if the test passes. the rest of the elements are
|
||||
;; procedures that build the attrs
|
||||
;; this field is #f when there is no synthesized attrs
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
(list (cons prop:contract lazy-contract-property))))
|
||||
|
||||
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses
|
||||
helper-id-var helper-info helper-freev
|
||||
enforcer-id-var)
|
||||
(define (make-free-vars free-vars freev)
|
||||
(let loop ([i 0]
|
||||
[stx null]
|
||||
[free-vars free-vars])
|
||||
(cond
|
||||
[(null? free-vars) (reverse stx)]
|
||||
[else (loop (+ i 1)
|
||||
(cons (with-syntax ((var (car free-vars))
|
||||
|
|
@ -337,87 +350,87 @@ it around flattened out.
|
|||
(j (+ i 2)))
|
||||
(syntax (var (opt-wrap-get stct j)))) stx)
|
||||
(cdr free-vars))])))
|
||||
|
||||
(let*-values ([(inner-val) #'val]
|
||||
[(clauses lifts superlifts stronger-ribs)
|
||||
(build-enforcer-clauses opt/i
|
||||
(opt/info-change-val inner-val opt/info)
|
||||
name
|
||||
stx
|
||||
clauses
|
||||
(list (syntax f-x) ...)
|
||||
(list (list (syntax f-xs) ...) ...)
|
||||
helper-id-var
|
||||
helper-info
|
||||
helper-freev)])
|
||||
(with-syntax ([(clause (... ...)) clauses]
|
||||
[enforcer-id enforcer-id-var]
|
||||
[helper-id helper-id-var]
|
||||
[((free-var free-var-val) (... ...))
|
||||
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
|
||||
[(saved-lifts (... ...)) (lifts-to-save lifts)])
|
||||
(values
|
||||
#`(λ (stct f-x ...)
|
||||
(let ((free-var free-var-val) (... ...))
|
||||
#,(bind-lifts
|
||||
lifts
|
||||
#'(let* (clause (... ...))
|
||||
(values f-x ...)))))
|
||||
lifts
|
||||
superlifts
|
||||
stronger-ribs))))
|
||||
|
||||
;;
|
||||
;; struct/dc opter
|
||||
;;
|
||||
(define/opter (struct/dc opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ clause (... ...))
|
||||
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
|
||||
(helper-id-var (car (generate-temporaries (syntax (helper)))))
|
||||
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))
|
||||
(id-var (car (generate-temporaries (syntax (id))))))
|
||||
(let-values ([(enforcer lifts superlifts stronger-ribs)
|
||||
(build-enforcer opt/i
|
||||
opt/info
|
||||
'struct/dc
|
||||
stx
|
||||
(syntax (clause (... ...)))
|
||||
helper-id-var
|
||||
#'info
|
||||
#'freev
|
||||
enforcer-id-var)])
|
||||
(let ([to-save (append (opt/info-free-vars opt/info)
|
||||
(lifts-to-save lifts))])
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(enforcer-id enforcer-id-var)
|
||||
(helper-id helper-id-var)
|
||||
(contract/info contract/info-var)
|
||||
(id id-var)
|
||||
((j (... ...)) (let loop ([i 2]
|
||||
[lst to-save])
|
||||
(cond
|
||||
|
||||
(let*-values ([(inner-val) #'val]
|
||||
[(clauses lifts superlifts stronger-ribs)
|
||||
(build-enforcer-clauses opt/i
|
||||
(opt/info-change-val inner-val opt/info)
|
||||
name
|
||||
stx
|
||||
clauses
|
||||
(list (syntax f-x) ...)
|
||||
(list (list (syntax f-xs) ...) ...)
|
||||
helper-id-var
|
||||
helper-info
|
||||
helper-freev)])
|
||||
(with-syntax ([(clause (... ...)) clauses]
|
||||
[enforcer-id enforcer-id-var]
|
||||
[helper-id helper-id-var]
|
||||
[((free-var free-var-val) (... ...))
|
||||
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
|
||||
[(saved-lifts (... ...)) (lifts-to-save lifts)])
|
||||
(values
|
||||
#`(λ (stct f-x ...)
|
||||
(let ((free-var free-var-val) (... ...))
|
||||
#,(bind-lifts
|
||||
lifts
|
||||
#'(let* (clause (... ...))
|
||||
(values f-x ...)))))
|
||||
lifts
|
||||
superlifts
|
||||
stronger-ribs))))
|
||||
|
||||
;;
|
||||
;; struct/dc opter
|
||||
;;
|
||||
(define/opter (struct/dc opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ clause (... ...))
|
||||
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
|
||||
(helper-id-var (car (generate-temporaries (syntax (helper)))))
|
||||
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))
|
||||
(id-var (car (generate-temporaries (syntax (id))))))
|
||||
(let-values ([(enforcer lifts superlifts stronger-ribs)
|
||||
(build-enforcer opt/i
|
||||
opt/info
|
||||
'struct/dc
|
||||
stx
|
||||
(syntax (clause (... ...)))
|
||||
helper-id-var
|
||||
#'info
|
||||
#'freev
|
||||
enforcer-id-var)])
|
||||
(let ([to-save (append (opt/info-free-vars opt/info)
|
||||
(lifts-to-save lifts))])
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(enforcer-id enforcer-id-var)
|
||||
(helper-id helper-id-var)
|
||||
(contract/info contract/info-var)
|
||||
(id id-var)
|
||||
((j (... ...)) (let loop ([i 2]
|
||||
[lst to-save])
|
||||
(cond
|
||||
[(null? lst) null]
|
||||
[else (cons i (loop (+ i 1) (cdr lst)))])))
|
||||
((free-var (... ...)) to-save))
|
||||
(with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
|
||||
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
|
||||
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
|
||||
[(stronger-indexes (... ...)) (build-list (length stronger-ribs)
|
||||
(λ (x) (+ x 2)))]
|
||||
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
|
||||
|
||||
(let ([partials
|
||||
(list (cons id-var #'(begin-lifted (box 'identity)))
|
||||
(cons enforcer-id-var enforcer)
|
||||
(cons contract/info-var
|
||||
(syntax
|
||||
(make-opt-contract/info ctc enforcer-id id))))])
|
||||
(values
|
||||
(syntax
|
||||
(cond
|
||||
((free-var (... ...)) to-save))
|
||||
(with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
|
||||
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
|
||||
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
|
||||
[(stronger-indexes (... ...)) (build-list (length stronger-ribs)
|
||||
(λ (x) (+ x 2)))]
|
||||
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
|
||||
|
||||
(let ([partials
|
||||
(list (cons id-var #'(begin-lifted (box 'identity)))
|
||||
(cons enforcer-id-var enforcer)
|
||||
(cons contract/info-var
|
||||
(syntax
|
||||
(make-opt-contract/info ctc enforcer-id id))))])
|
||||
(values
|
||||
(syntax
|
||||
(cond
|
||||
[(opt-wrap-predicate val)
|
||||
(if (and (opt-wrap-get val 0)
|
||||
(let ([stronger-this-var stronger-var]
|
||||
|
|
@ -433,10 +446,10 @@ it around flattened out.
|
|||
;; the rest of this test is bogus and may fail at runtime
|
||||
(eq? id (opt-contract/info-id (opt-wrap-get val 1)))
|
||||
stronger-exps (... ...))))
|
||||
val
|
||||
(let ([w (opt-wrap-maker val contract/info)])
|
||||
(opt-wrap-set w j free-var) (... ...)
|
||||
w))]
|
||||
val
|
||||
(let ([w (opt-wrap-maker val contract/info)])
|
||||
(opt-wrap-set w j free-var) (... ...)
|
||||
w))]
|
||||
[(or (raw-predicate val)
|
||||
(wrap-predicate val))
|
||||
(let ([w (opt-wrap-maker val contract/info)])
|
||||
|
|
@ -449,13 +462,29 @@ it around flattened out.
|
|||
"expected <~a>, got ~e"
|
||||
(contract-name ctc)
|
||||
val)]))
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
#f
|
||||
#f
|
||||
stronger-ribs)))))))]))
|
||||
)))]))
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
#f
|
||||
#f
|
||||
stronger-ribs)))))))]))
|
||||
)))))
|
||||
|
||||
(define-syntax (define-contract-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (fields ...))
|
||||
(syntax (define-contract-struct name (fields ...) (current-inspector)))]
|
||||
[(_ name (fields ...) inspector)
|
||||
(and (identifier? (syntax name))
|
||||
(andmap identifier? (syntax->list (syntax (fields ...)))))
|
||||
(main stx #'name #'(fields ...) #'inspector #t)]))
|
||||
|
||||
(define-syntax (contract-struct stx)
|
||||
(syntax-case stx()
|
||||
[(_ name (fields ...))
|
||||
#'(contract-struct name (fields ...) #:inspector (current-inspector))]
|
||||
[(_ name (fields ...) #:inspector e)
|
||||
(main stx #'name #'(fields ...) #'e #f)]))
|
||||
|
||||
(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.ss")
|
||||
@(require "mz.rkt")
|
||||
@(require (for-label syntax/modcollapse))
|
||||
|
||||
@(define contract-eval
|
||||
|
|
@ -710,18 +710,17 @@ be blamed using the above contract:
|
|||
|
||||
@section{Lazy Data-structure Contracts}
|
||||
|
||||
@defform[
|
||||
(define-contract-struct id (field-id ...))
|
||||
]{
|
||||
@defform[(contract-struct id (field-id ...))]{
|
||||
|
||||
Like @racket[define-struct], but with two differences: it does not
|
||||
define field mutators, and it does define two contract constructors:
|
||||
Like @racket[struct], but with two differences:
|
||||
they do not
|
||||
define field mutators, and the do define two contract constructors:
|
||||
@racket[id]@racketidfont{/c} and @racket[id]@racketidfont{/dc}. The
|
||||
first is a procedure that accepts as many arguments as there are
|
||||
fields and returns a contract for struct values whose fields match the
|
||||
arguments. The second is a syntactic form that also produces contracts
|
||||
on the structs, but the contracts on later fields may depend on the
|
||||
values of earlier fields.
|
||||
values of earlier fields.
|
||||
|
||||
The generated contract combinators are @italic{lazy}: they only verify
|
||||
the contract holds for the portion of some data structure that is
|
||||
|
|
@ -739,21 +738,26 @@ not checked until a selector extracts a field of a struct.
|
|||
In each @racket[field-spec] case, the first @racket[field-id]
|
||||
specifies which field the contract applies to; the fields must be
|
||||
specified in the same order as the original
|
||||
@racket[define-contract-struct]. The first case is for when the
|
||||
@racket[contract-struct]. The first case is for when the
|
||||
contract on the field does not depend on the value of any other
|
||||
field. The second case is for when the contract on the field does
|
||||
depend on some other fields, and the parenthesized @racket[field-id]s
|
||||
indicate which fields it depends on; these dependencies can only be to
|
||||
earlier fields.}
|
||||
earlier fields.}}
|
||||
|
||||
@defform[(define-contract-struct id (field-id ...))]{
|
||||
Like @racket[contract-struct], but where the maker's name is @racketidfont["make-"]@racket[id],
|
||||
much like @racket[define-struct].
|
||||
}
|
||||
|
||||
As an example, consider the following module:
|
||||
As an example of lazy contract checking, consider the following module:
|
||||
|
||||
@(begin
|
||||
#reader scribble/comment-reader
|
||||
[racketmod
|
||||
racket
|
||||
|
||||
(define-contract-struct kons (hd tl))
|
||||
(contract-struct kons (hd tl))
|
||||
|
||||
;; @racket[sorted-list/gt : number -> contract]
|
||||
;; produces a contract that accepts
|
||||
|
|
@ -778,7 +782,7 @@ racket
|
|||
(* (kons-hd l)
|
||||
(product (kons-tl l))))]))
|
||||
|
||||
(provide kons? make-kons kons-hd kons-tl)
|
||||
(provide kons? kons kons-hd kons-tl)
|
||||
(provide/contract [product (-> (sorted-list/gt -inf.0) number?)])
|
||||
])
|
||||
|
||||
|
|
|
|||
|
|
@ -7941,6 +7941,16 @@
|
|||
[tl (hd) (-> (>=/c hd) (>=/c hd))])])
|
||||
((couple-tl (contract c x 'pos 'neg)) -11)))
|
||||
|
||||
(contract-eval '(contract-struct no-define (x)))
|
||||
(test/spec-passed/result
|
||||
'd-c-s43
|
||||
'(no-define-x (no-define 1))
|
||||
'1)
|
||||
(test/spec-passed/result
|
||||
'd-c-s44
|
||||
'(no-define? (no-define 1))
|
||||
'#t)
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user