252 lines
11 KiB
Scheme
252 lines
11 KiB
Scheme
|
|
(module contract-ds mzscheme
|
|
(require "contract-guts.ss")
|
|
(require-for-syntax "contract-ds-helpers.ss"
|
|
"contract-helpers.scm")
|
|
|
|
(provide define-contract-struct)
|
|
|
|
(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* ([add-suffix
|
|
(λ (suffix)
|
|
(datum->syntax-object (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 (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 ...)))])
|
|
(with-syntax ([struct/c struct/c-name/val]
|
|
[struct/dc struct/dc-name/val]
|
|
[field-count field-count/val]
|
|
[(selectors ...) selectors/val]
|
|
[struct-maker struct-maker/val]
|
|
[predicate predicate/val]
|
|
[contract-name (add-suffix "-contract")]
|
|
[(selector-indicies ...) (nums-up-to field-count/val)]
|
|
[(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))]
|
|
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
|
|
[(f-x ...) f-x/vals]
|
|
[((f-xs ...) ...) (generate-arglists f-x/vals)]
|
|
[wrap-name (string->symbol (format "~a/lazy-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)
|
|
(values))))
|
|
(list))
|
|
|
|
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
|
|
(make-struct-type 'wrap-name
|
|
#f ;; super struct
|
|
2 ;; field count
|
|
(- field-count 1) ;; 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) (wrap-predicate x)))
|
|
|
|
(define-syntax (struct/dc stx)
|
|
(syntax-case stx ()
|
|
[(_ clause (... ...))
|
|
(with-syntax ([(maker-args (... ...))
|
|
(build-clauses 'struct/dc
|
|
(syntax coerce-contract)
|
|
stx
|
|
(syntax (clause (... ...))))])
|
|
(syntax (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-indicies) ...)]
|
|
[else
|
|
(let ([inner (wrap-get stct 0)])
|
|
(if inner
|
|
;; we have a contract to update
|
|
(let-values ([(_1 fields ...) (loop inner)])
|
|
(let-values ([(fields ...)
|
|
(rewrite-fields (wrap-get stct 1) fields ...)])
|
|
(wrap-set stct 0 #f)
|
|
(wrap-set stct selector-indicies+1 fields) ...
|
|
(values stct fields ...)))
|
|
|
|
;; found a cached version of the value
|
|
(values #f (wrap-get stct selector-indicies+1) ...)))]))])
|
|
(wrap-get stct i+1)))
|
|
|
|
(define (rewrite-fields contract/info ctc-x ...)
|
|
(let* ([f-x (let ([ctc-field (contract-get (contract/info-contract contract/info) selector-indicies)])
|
|
(let ([ctc (if (procedure? ctc-field)
|
|
(ctc-field f-xs ...)
|
|
ctc-field)])
|
|
((((proj-get ctc) ctc) (contract/info-pos contract/info)
|
|
(contract/info-neg contract/info)
|
|
(contract/info-src-info contract/info)
|
|
(contract/info-orig-str contract/info))
|
|
ctc-x)))] ...)
|
|
(values f-x ...)))
|
|
|
|
(define (stronger-lazy-contract? a b)
|
|
(and (contract-predicate b)
|
|
(check-sub-contract?
|
|
(contract-get a selector-indicies)
|
|
(contract-get b selector-indicies)) ...))
|
|
|
|
(define (lazy-contract-proj ctc)
|
|
(λ (pos neg src-info orig-str)
|
|
(let ([contract/info (make-contract/info ctc pos neg src-info orig-str)])
|
|
(λ (val)
|
|
(unless (or (wrap-predicate val)
|
|
(raw-predicate val))
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
neg
|
|
orig-str
|
|
"expected <~a>, got ~e" 'name val))
|
|
(cond
|
|
[(already-there? ctc val lazy-depth-to-look)
|
|
val]
|
|
[else
|
|
(wrap-maker val contract/info)])))))
|
|
|
|
(define (already-there? ctc val depth)
|
|
(cond
|
|
[(raw-predicate val) #f]
|
|
[(zero? depth) #f]
|
|
[(wrap-get val 0)
|
|
(if (contract-stronger? (contract/info-contract (wrap-get val 1)) ctc)
|
|
#t
|
|
(already-there? ctc (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 ...)))
|
|
|
|
(define (no-depend-apply-to-fields ctc fields ...)
|
|
(let ([ctc-x (contract-get ctc selector-indicies)] ...)
|
|
(values (((proj-get ctc-x) ctc-x) fields) ...)))
|
|
|
|
(define (selectors x) (burrow-in x 'selectors selector-indicies)) ...
|
|
|
|
(define (burrow-in struct selector-name i)
|
|
(cond
|
|
[(raw-predicate struct)
|
|
(get struct i)]
|
|
[(wrap-predicate struct)
|
|
(if (wrap-get struct 0)
|
|
(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)
|
|
(let ([list-of-subcontracts (list (contract-get ctc selector-indicies) ...)])
|
|
(cond
|
|
[(andmap contract? list-of-subcontracts)
|
|
(apply build-compound-type-name 'struct/c list-of-subcontracts)]
|
|
[else
|
|
(let ([dots (string->symbol "...")])
|
|
(apply build-compound-type-name 'struct/dc
|
|
(map (λ (field ctc)
|
|
(if (contract? ctc)
|
|
(build-compound-type-name field ctc)
|
|
(build-compound-type-name field dots)))
|
|
'(fields ...)
|
|
list-of-subcontracts)))])))
|
|
|
|
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
|
|
(make-struct-type 'contract-name
|
|
#f
|
|
field-count
|
|
0 ;; auto-field-k
|
|
'() ;; auto-field-v
|
|
(list (cons proj-prop lazy-contract-proj)
|
|
(cons name-prop lazy-contract-name)
|
|
(cons stronger-prop stronger-lazy-contract?)))))))]))
|
|
|
|
(define-struct contract/info (contract pos neg src-info orig-str))
|
|
|
|
(define max-cache-size 5)
|
|
(define lazy-depth-to-look 5)
|
|
|
|
(define (check-sub-contract? x y)
|
|
(cond
|
|
[(and (proj-pred? x) (proj-pred? y))
|
|
(contract-stronger? x y)]
|
|
[(and (procedure? x) (procedure? y))
|
|
(procedure-closure-contents-eq? x y)]
|
|
[else #f]))
|
|
|
|
#|
|
|
test case:
|
|
(define-contract-struct s (a b))
|
|
|
|
this contract:
|
|
|
|
(s/dc [a (flat number?)]
|
|
[b (λ (x) (and (number? x) (< a b)))])
|
|
|
|
should not signal a less than error for this value:
|
|
|
|
(make-s #f 2)
|
|
|
|
but this one:
|
|
|
|
(s/dc [a (flat boolean?)]
|
|
[b (λ (x) (and (number? x) (< a b)))])
|
|
|
|
should
|
|
|
|
|#
|
|
|
|
#|
|
|
|
|
test-case:
|
|
(define-contract-struct s (a b))
|
|
(s/dc [x 1])
|
|
=> wrong field count exn
|
|
|#
|
|
|
|
|
|
) |