start adding struct/dc contracts
This commit is contained in:
Robby Findler
parent
a4381dd1f6
commit
04017d83d5
|
|
@ -7,6 +7,7 @@
|
|||
"private/hash.rkt"
|
||||
"private/vector.rkt"
|
||||
"private/struct.rkt"
|
||||
"private/struct-dc.rkt"
|
||||
"private/struct-prop.rkt"
|
||||
"private/misc.rkt"
|
||||
"private/provide.rkt"
|
||||
|
|
@ -31,6 +32,7 @@
|
|||
"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")
|
||||
current-contract-region)
|
||||
|
|
|
|||
|
|
@ -209,6 +209,7 @@
|
|||
;; sorts the arguments according to the dependency order.
|
||||
;; returns them in the reverse of that order, ie expressions that need
|
||||
;; to be evaluted first come later in the list.
|
||||
;; BAD: this seem wrong, as it doesn't consider transitive dependencies
|
||||
(define-for-syntax (find-ordering args)
|
||||
|
||||
(define (comes-before? x y)
|
||||
|
|
|
|||
1035
collects/racket/contract/private/struct-dc.rkt
Normal file
1035
collects/racket/contract/private/struct-dc.rkt
Normal file
File diff suppressed because it is too large
Load Diff
|
|
@ -13,8 +13,7 @@
|
|||
"misc.rkt"
|
||||
"opt.rkt")
|
||||
|
||||
(provide struct/c
|
||||
(rename-out [-struct/dc struct/dc]))
|
||||
(provide struct/c)
|
||||
|
||||
(define-syntax (struct/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -245,371 +244,3 @@
|
|||
[else
|
||||
(make-impersonator-struct/c struct-name predicate immutables mutables)]))
|
||||
|
||||
(define unique (box #f))
|
||||
(define (un-dep ctc obj blame immutable-field)
|
||||
(let ([ctc (coerce-contract 'struct/dc ctc)])
|
||||
(when immutable-field
|
||||
(check-chaperone-contract immutable-field ctc))
|
||||
(((contract-projection ctc) blame) obj)))
|
||||
|
||||
(define (struct/dc-name ctc)
|
||||
(define info (struct/dc-name-info ctc))
|
||||
`(struct/dc ,(vector-ref info 0)
|
||||
,@(for/list ([x (in-list (vector-ref info 1))]
|
||||
[subctc (in-list (struct/dc-procs/ctcs ctc))])
|
||||
`[,@(vector-ref x 1)
|
||||
,(if (vector-ref x 0)
|
||||
(contract-name subctc)
|
||||
'...)])))
|
||||
|
||||
(define (struct/dc-first-order ctc)
|
||||
(struct/dc-pred ctc))
|
||||
|
||||
(define (struct/dc-proj ctc)
|
||||
(define pred? (struct/dc-pred ctc))
|
||||
(define mk-proj ((struct/dc-apply-proj ctc) ctc))
|
||||
(λ (blame)
|
||||
(define proj (mk-proj blame))
|
||||
(λ (v)
|
||||
(cond
|
||||
[(and (struct/dc-imp-prop-pred? v)
|
||||
(contract-stronger? (struct/dc-imp-prop-get v) ctc))
|
||||
v]
|
||||
[else
|
||||
(unless (pred? v)
|
||||
(raise-blame-error blame v "expected a ~a"
|
||||
(struct/dc-struct-name ctc)))
|
||||
(proj v)]))))
|
||||
|
||||
(define (struct/dc-stronger? this that)
|
||||
(and (struct/dc? that)
|
||||
(eq? (struct/dc-pred this)
|
||||
(struct/dc-pred that))
|
||||
(let loop ([this-procs/ctcs (struct/dc-procs/ctcs this)]
|
||||
[that-procs/ctcs (struct/dc-procs/ctcs that)])
|
||||
(cond
|
||||
[(and (null? this-procs/ctcs) (null? that-procs/ctcs)) #t]
|
||||
[(and (pair? this-procs/ctcs) (pair? that-procs/ctcs))
|
||||
(define fst-this (car this-procs/ctcs))
|
||||
(define fst-that (car that-procs/ctcs))
|
||||
(cond
|
||||
[(and (contract-struct? fst-this) (contract-struct? fst-that))
|
||||
(and (contract-stronger? fst-this fst-that)
|
||||
(loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
|
||||
[(and (procedure? fst-this) (procedure? fst-that))
|
||||
(and (procedure-closure-contents-eq? fst-this fst-that)
|
||||
(loop (cdr this-procs/ctcs) (cdr that-procs/ctcs)))]
|
||||
[else #f])]
|
||||
[else #f]))))
|
||||
|
||||
(define-struct struct/dc (apply-proj procs/ctcs pred struct-name here name-info)
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:name struct/dc-name
|
||||
#:first-order struct/dc-first-order
|
||||
#:projection struct/dc-proj
|
||||
#:stronger struct/dc-stronger?)))
|
||||
|
||||
(define-for-syntax (get-struct-info id stx)
|
||||
(define inf (syntax-local-value id (λ () #f)))
|
||||
(unless (struct-info? inf)
|
||||
(raise-syntax-error 'struct/dc "expected a struct" stx id))
|
||||
(define the-info (extract-struct-info inf))
|
||||
(unless (list-ref the-info 2)
|
||||
(raise-syntax-error 'struct/dc
|
||||
"expected a struct with a known predicate"
|
||||
stx id))
|
||||
the-info)
|
||||
|
||||
(define-values (struct/dc-imp-prop-desc
|
||||
struct/dc-imp-prop-pred?
|
||||
struct/dc-imp-prop-get)
|
||||
(make-impersonator-property 'struct/dc))
|
||||
|
||||
|
||||
(define-for-syntax (clause->chap-proc struct-id info stx clause-stx)
|
||||
(define sel-id (syntax-case clause-stx ()
|
||||
[(sel-id . rest) #'sel-id]))
|
||||
(define (add-prefix id)
|
||||
(datum->syntax id
|
||||
(string->symbol (format "~a-~a"
|
||||
(syntax-e sel-id)
|
||||
(syntax-e id)))))
|
||||
(define immutable-field
|
||||
(for/or ([mutator (in-list (list-ref info 4))]
|
||||
[selector (in-list (list-ref info 3))])
|
||||
(cond
|
||||
[(and (not mutator) (not selector))
|
||||
;; end, with some hidden info
|
||||
;; just assume not immutable
|
||||
#f]
|
||||
[else
|
||||
(and (not mutator)
|
||||
(let ([id (id->sel-id struct-id sel-id)])
|
||||
(and (free-identifier=? id selector)
|
||||
id)))])))
|
||||
(define (add-immutable-check ctc-id stx)
|
||||
(if immutable-field
|
||||
(list stx
|
||||
#`(check-chaperone-contract '#,immutable-field #,ctc-id))
|
||||
(list stx)))
|
||||
|
||||
(syntax-case clause-stx ()
|
||||
;; with caching
|
||||
[(sel-id #:lazy (id ...) exp)
|
||||
(with-syntax ([(dep-sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
|
||||
(with-syntax ([dep-proc (add-prefix #'dep-proc)])
|
||||
#`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
|
||||
(begin)
|
||||
(begin)
|
||||
(begin)
|
||||
(let ([cached unique])
|
||||
(λ (strct fld)
|
||||
(if (eq? cached unique)
|
||||
(begin
|
||||
(set! cached (un-dep (dep-proc (dep-sel-id strct) ...) fld blame '#,immutable-field))
|
||||
cached)
|
||||
cached)))
|
||||
#(#f (sel-id #:lazy (id ...))))))]
|
||||
[(sel-id (id ...) exp)
|
||||
(with-syntax ([(dep-sel-id ...) (map (λ (x) (id->sel-id struct-id x)) (syntax->list #'(id ...)))])
|
||||
(with-syntax ([dep-proc (add-prefix #'dep-proc)])
|
||||
#`(((define dep-proc (λ (id ...) #,(defeat-inlining #'exp))))
|
||||
(begin)
|
||||
(begin)
|
||||
(un-dep (dep-proc (dep-sel-id v) ...) (#,(id->sel-id struct-id #'sel-id) v) blame '#,immutable-field)
|
||||
(λ (strct fld)
|
||||
(un-dep (dep-proc (dep-sel-id strct) ...) fld blame '#,immutable-field))
|
||||
#(#f (sel-id (id ...))))))]
|
||||
[(sel-id #:lazy exp)
|
||||
(with-syntax ([ctc (add-prefix #'ctc)]
|
||||
[blame-to-proj (add-prefix #'blame-to-proj)]
|
||||
[proj (add-prefix #'proj)])
|
||||
#`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
|
||||
(define blame-to-proj (contract-struct-projection ctc))
|
||||
(define proj (blame-to-proj blame))
|
||||
(begin)
|
||||
(let ([cached unique])
|
||||
(λ (strct fld)
|
||||
(if (eq? cached unique)
|
||||
(begin
|
||||
(set! cached (proj fld))
|
||||
cached)
|
||||
cached)))
|
||||
#(#t (sel-id #:lazy))))]
|
||||
[(sel-id exp)
|
||||
(with-syntax ([ctc (add-prefix #'ctc)]
|
||||
[blame-to-proj (add-prefix #'blame-to-proj)]
|
||||
[proj (add-prefix #'proj)])
|
||||
#`(#,(add-immutable-check #'ctc #'(define ctc (coerce-contract 'struct/dc exp)))
|
||||
(define blame-to-proj (contract-struct-projection ctc))
|
||||
(define proj (blame-to-proj blame))
|
||||
(proj (#,(id->sel-id struct-id #'sel-id) v))
|
||||
(if (flat-contract? ctc)
|
||||
(λ (strct fld) fld)
|
||||
(λ (strct fld) (proj fld)))
|
||||
#(#t (sel-id))))]
|
||||
[_ (raise-syntax-error #f "malformed clause" stx clause-stx)]))
|
||||
|
||||
(define (check-chaperone-contract immutable-field ctc)
|
||||
(unless (chaperone-contract? ctc)
|
||||
(error 'struct/dc "expected a chaperone contract for the immutable field ~a, got ~e"
|
||||
immutable-field
|
||||
ctc)))
|
||||
|
||||
(define-for-syntax (id->sel-id struct-id id)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e struct-id)
|
||||
(syntax-e id)))))
|
||||
|
||||
(define-syntax (-struct/dc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ struct-id clause ...)
|
||||
(let ()
|
||||
(define info (get-struct-info #'struct-id stx))
|
||||
(with-syntax ([(((before-ctc-bound ...) after-ctc-bound after-blame-bound first-order-check chap-proc name-info) ...)
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))])
|
||||
(clause->chap-proc #'struct-id info stx clause))])
|
||||
(with-syntax ([(id ...) (syntax-case #'((before-ctc-bound ...) ...) ()
|
||||
[(((define id exp) . whatever) ...) #'(id ...)])]
|
||||
[(selectors+chap-procs ...)
|
||||
(apply
|
||||
append
|
||||
(for/list ([clause (in-list (syntax->list #'(clause ...)))]
|
||||
[chap-proc (in-list (syntax->list #'(chap-proc ...)))])
|
||||
(list (id->sel-id
|
||||
#'struct-id
|
||||
(syntax-case clause ()
|
||||
[(x . rest) #'x]))
|
||||
chap-proc)))])
|
||||
#`(let ()
|
||||
before-ctc-bound ... ...
|
||||
(letrec ([me
|
||||
(make-struct/dc
|
||||
(λ (ctc)
|
||||
after-ctc-bound ...
|
||||
(λ (blame)
|
||||
after-blame-bound ...
|
||||
(λ (v)
|
||||
first-order-check ...
|
||||
(chaperone-struct
|
||||
v
|
||||
selectors+chap-procs ...
|
||||
struct/dc-imp-prop-desc
|
||||
me))))
|
||||
(list id ...)
|
||||
#,(list-ref info 2)
|
||||
'struct-id
|
||||
(quote-module-name)
|
||||
'#(struct-id (name-info ...)))])
|
||||
me)))))]))
|
||||
|
||||
(define/opter (-struct/dc opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ struct-id clause ...)
|
||||
(let ()
|
||||
(define info (get-struct-info #'struct-id stx))
|
||||
(cond
|
||||
[(ormap values (list-ref info 4))
|
||||
;; any mutable struct, just give up (could generate impersonator code, but
|
||||
;; would have to check that the compiled subcontracts are all chaperones/flats)
|
||||
(opt/unknown opt/i opt/info stx)]
|
||||
[else
|
||||
(define-values (s-chap-code s-flat-code s-lifts s-super-lifts s-partially-applied can-be-optimized? stronger-ribs chaperone?)
|
||||
(for/fold ([s-chap-code '()]
|
||||
[s-flat-code '()]
|
||||
[s-lifts '()]
|
||||
[s-super-lifts '()]
|
||||
[s-partially-applied '()]
|
||||
[can-be-optimized? #t]
|
||||
[stronger-ribs '()]
|
||||
[chaperone? #t])
|
||||
([clause (in-list (syntax->list #'(clause ...)))])
|
||||
|
||||
(define-values (sel-id lazy? dep-vars exp)
|
||||
(syntax-case clause ()
|
||||
[(sel-id #:lazy exp) (values #'sel-id #t #f #'exp)]
|
||||
[(sel-id exp) (values #'sel-id #f #f #'exp)]
|
||||
[(sel-id #:lazy (dep-id ...) exp) (values #'sel-id #t #'(dep-id ...) #'exp)]
|
||||
[(sel-id (dep-id ...) exp) (values #'sel-id #f #'(dep-id ...) #'exp)]))
|
||||
|
||||
(define-values (this-code
|
||||
this-lifts this-super-lifts this-partially-applied
|
||||
this-flat? this-can-be-optimized? this-stronger-ribs
|
||||
this-chaperone?)
|
||||
(opt/i opt/info exp))
|
||||
|
||||
(values (cond
|
||||
[(and this-flat? (not lazy?) (not dep-vars))
|
||||
s-chap-code]
|
||||
[else
|
||||
(with-syntax ([(strct cache) (generate-temporaries '(struct cache))]
|
||||
[proc-name (string->symbol
|
||||
(format "~a-~a-chap/dep"
|
||||
(syntax-e #'struct-id)
|
||||
(syntax-e sel-id)))])
|
||||
(list* (cond
|
||||
[dep-vars
|
||||
(with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var))
|
||||
(syntax->list dep-vars))]
|
||||
[(dep-var ...) dep-vars])
|
||||
(with-syntax ([this-code+lifts
|
||||
#`(let ([dep-var (sel strct)] ...)
|
||||
#,(bind-superlifts
|
||||
this-super-lifts
|
||||
(bind-lifts
|
||||
this-lifts
|
||||
(bind-lifts
|
||||
this-partially-applied
|
||||
this-code))))])
|
||||
(if lazy?
|
||||
#`(let ([cache unique])
|
||||
(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
(cond
|
||||
[(eq? cache unique)
|
||||
(set! cache this-code+lifts)
|
||||
cache]
|
||||
[else cache]))])
|
||||
proc-name))
|
||||
#`(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
this-code+lifts)])
|
||||
proc-name))))]
|
||||
[else
|
||||
(if lazy?
|
||||
#`(let ([cache unique])
|
||||
(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
(cond
|
||||
[(eq? cache unique)
|
||||
(set! cache #,this-code)
|
||||
cache]
|
||||
[else cache]))])
|
||||
proc-name))
|
||||
#`(let ([proc-name
|
||||
(λ (strct #,(opt/info-val opt/info))
|
||||
#,this-code)])
|
||||
proc-name))])
|
||||
(id->sel-id #'struct-id sel-id)
|
||||
s-chap-code))])
|
||||
(cond
|
||||
[lazy?
|
||||
s-flat-code]
|
||||
[dep-vars
|
||||
(with-syntax ([(sel ...) (map (λ (var) (id->sel-id #'struct-id var))
|
||||
(syntax->list dep-vars))]
|
||||
[(dep-var ...) dep-vars])
|
||||
(cons #` (let ([dep-var (sel #,(opt/info-val opt/info))] ...)
|
||||
(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
|
||||
#,(opt/info-val opt/info))])
|
||||
#,this-code))
|
||||
s-flat-code))]
|
||||
[else
|
||||
(cons #`(let ([#,(opt/info-val opt/info) (#,(id->sel-id #'struct-id sel-id)
|
||||
#,(opt/info-val opt/info))])
|
||||
#,this-code)
|
||||
s-flat-code)])
|
||||
(if dep-vars s-lifts (append this-lifts s-lifts))
|
||||
(if dep-vars s-super-lifts (append this-super-lifts s-super-lifts))
|
||||
(if dep-vars s-partially-applied (append this-partially-applied s-partially-applied))
|
||||
(and this-can-be-optimized? can-be-optimized?)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and this-chaperone? chaperone?))))
|
||||
(with-syntax ([(stronger-prop-desc stronger-prop-pred? stronger-prop-get)
|
||||
(syntax-local-lift-values-expression
|
||||
3
|
||||
#'(make-impersonator-property 'struct/dc-stronger-prop))]
|
||||
[(free-var ...) (opt/info-free-vars opt/info)]
|
||||
[(index ...) (build-list (length (opt/info-free-vars opt/info)) values)]
|
||||
[pred? (list-ref info 2)])
|
||||
(values #`(if (and (stronger-prop-pred? #,(opt/info-val opt/info))
|
||||
(let ([v (stronger-prop-get #,(opt/info-val opt/info))])
|
||||
(and (eq? (vector-ref v index) free-var) ...)))
|
||||
#,(opt/info-val opt/info)
|
||||
(if (pred? #,(opt/info-val opt/info))
|
||||
(begin
|
||||
#,@(reverse s-flat-code) ;; built the last backwards, so reverse it here
|
||||
(chaperone-struct
|
||||
#,(opt/info-val opt/info)
|
||||
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
|
||||
stronger-prop-desc
|
||||
(vector free-var ...)))
|
||||
(struct/dc-error blame #,(opt/info-val opt/info) 'struct-name)))
|
||||
s-lifts
|
||||
s-super-lifts
|
||||
s-partially-applied
|
||||
#f ;; flat sexp
|
||||
can-be-optimized?
|
||||
stronger-ribs
|
||||
#t ;;chaperone?
|
||||
))]))]))
|
||||
|
||||
(define (struct/dc-error blame obj what)
|
||||
(raise-blame-error blame obj
|
||||
"expected a struct of type ~a"
|
||||
what))
|
||||
|
|
|
|||
59
collects/racket/contract/private/top-sort.rkt
Normal file
59
collects/racket/contract/private/top-sort.rkt
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
(provide top-sort)
|
||||
;; top-sort : (listof α) (α -> (listof α)) -> (listof α) or #f
|
||||
;; returns #f if there is a cycle in the graph
|
||||
;; (α needs hashing)
|
||||
(define (top-sort elements neighbors)
|
||||
(define parents (make-hash))
|
||||
(define children (make-hash))
|
||||
(define ids (make-hash))
|
||||
|
||||
(for ([element (in-list elements)]
|
||||
[n (in-naturals)])
|
||||
(hash-set! ids element n))
|
||||
|
||||
(define (add-link table from to)
|
||||
(hash-set! (hash-ref table from) to #t))
|
||||
|
||||
;; initialize the tables telling me about parents and children
|
||||
(for ([ele (in-list elements)])
|
||||
(hash-set! parents ele (make-hash))
|
||||
(hash-set! children ele (make-hash)))
|
||||
|
||||
(for ([parent (in-list elements)])
|
||||
(for ([child (in-list (neighbors parent))])
|
||||
(add-link parents parent child)
|
||||
(add-link children child parent)))
|
||||
|
||||
;; contains elements that have no (unscheduled) dependencies
|
||||
(define pending (make-hash))
|
||||
(for ([(k v) (in-hash parents)])
|
||||
(when (zero? (hash-count v))
|
||||
(hash-set! pending k #t)))
|
||||
|
||||
(define sorted
|
||||
(let loop ()
|
||||
(cond
|
||||
[(zero? (hash-count pending))
|
||||
'()]
|
||||
[else
|
||||
(define best #f)
|
||||
(for ([(ele _) (in-hash pending)])
|
||||
(cond
|
||||
[best
|
||||
(when (< (hash-ref ids ele) (hash-ref ids best))
|
||||
(set! best ele))]
|
||||
[else
|
||||
(set! best ele)]))
|
||||
(hash-remove! pending best)
|
||||
(for ([(child _) (in-hash (hash-ref children best))])
|
||||
(define childs-parents (hash-ref parents child))
|
||||
(hash-remove! childs-parents best)
|
||||
(when (zero? (hash-count childs-parents))
|
||||
(hash-set! pending child #t)))
|
||||
(cons best (loop))])))
|
||||
|
||||
(cond
|
||||
[(zero? (hash-count pending)) sorted]
|
||||
[else #f]))
|
||||
|
||||
|
|
@ -390,20 +390,40 @@ produced. Otherwise, an impersonator contract is produced.
|
|||
|
||||
|
||||
@defform/subs[(struct/dc struct-id field-spec ...)
|
||||
([field-spec [field-id contract-expr]
|
||||
[field-id #:lazy contract-expr]
|
||||
[field-id (dep-field-id ...) contract-expr]
|
||||
[field-id (dep-field-id ...) #:lazy contract-expr]])]{
|
||||
([field-spec [field-id maybe-lazy contract-expr]
|
||||
[field-id (dep-field-id ...)
|
||||
maybe-lazy
|
||||
maybe-impersonator
|
||||
maybe-flat
|
||||
maybe-dep-state
|
||||
contract-expr]]
|
||||
[maybe-lazy (code:line) #:lazy]
|
||||
[maybe-impersonator (code:line) #:impersonator]
|
||||
[maybe-flat (code:line) #:flat]
|
||||
[maybe-dep-state (code:line) #:depends-on-state])]{
|
||||
Produces a contract that recognizes instances of the structure
|
||||
type named by @racket[struct-id], and whose field values match the
|
||||
contracts produced by the @racket[field-spec]s.
|
||||
|
||||
Each @racket[field-spec] can specify if the field is check lazily
|
||||
(only when a selector is applied) or not via the @racket[#:lazy]
|
||||
keyword. If the @racket[field-spec] lists the names of other fields,
|
||||
keyword.
|
||||
|
||||
If the @racket[field-spec] lists the names of other fields,
|
||||
then the contract depends on values in those fields, and the @racket[contract-expr]
|
||||
expression is evaluated each time a selector is applied, building a new contract
|
||||
for the fields based on the values of the @racket[dep-field-id] fields.
|
||||
If the field is a dependent field, then it is assumed that the contract is
|
||||
always a chaperone contract. If this is not the case, and the contract is
|
||||
always flat, or sometimes not a chaperone, then the field must be annotated with
|
||||
the @racket[#:flat] or @racket[#:impersonator].
|
||||
|
||||
If a dependent contract depends on some mutable state, then use the
|
||||
@racket[#:depends-on-state] keyword argument (if a field's dependent contract
|
||||
depends on a mutable field, this keyword is automatically inferred).
|
||||
The presence of this keyword means that the contract expression is evaluated
|
||||
each time the corresponding field is accessed (or mutated, if it is a mutable
|
||||
field).
|
||||
|
||||
Contracts for immutable fields must be either flat or chaperone contracts.
|
||||
Contracts for mutable fields may be impersonator contracts.
|
||||
|
|
@ -412,7 +432,7 @@ 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.
|
||||
|
||||
For example, the function @racket[bst/c] below
|
||||
As an example, the function @racket[bst/c] below
|
||||
returns a contract for binary search trees whose values
|
||||
are all between @racket[lo] and @racket[hi].
|
||||
|
||||
|
|
|
|||
|
|
@ -3072,8 +3072,11 @@
|
|||
#'(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol #'here)
|
||||
(lambda (x)
|
||||
(and (exn:fail:contract:blame? x)
|
||||
(regexp-match? #px"<collects>"
|
||||
(exn-message x)))))
|
||||
(let ([msg (exn-message x)])
|
||||
(define ans (regexp-match? #px"<collects>" msg))
|
||||
(unless ans
|
||||
(printf "msg: ~s\n" msg))
|
||||
ans))))
|
||||
|
||||
;; make sure that ->i checks its arguments
|
||||
(contract-error-test
|
||||
|
|
@ -3724,6 +3727,13 @@
|
|||
(contract (-> funny/c any) void 'pos 'neg)))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'or/c-opt-unknown-flat
|
||||
(let ()
|
||||
(define arr (-> number? number?))
|
||||
((contract (opt/c (or/c not arr)) (λ (x) x) 'pos 'neg) 1)))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -9196,7 +9206,7 @@
|
|||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
[b (a) #:lazy (f a)]))
|
||||
|
||||
(s-a (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
|
|
@ -9211,7 +9221,7 @@
|
|||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
[b (a) #:lazy (f a)]))
|
||||
|
||||
(s-a (s-b (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
|
|
@ -9227,7 +9237,7 @@
|
|||
(define-opt/c (f z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (f a)]))
|
||||
[b (a) #:lazy (f a)]))
|
||||
(s-b (s-b (contract (f 11)
|
||||
(s 12 (s 13 #f))
|
||||
'pos
|
||||
|
|
@ -9242,7 +9252,7 @@
|
|||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
[b (a) #:lazy (>=/c (+ a 1))]))
|
||||
|
||||
(s-a (contract (g 10)
|
||||
(s 12 (s 14 #f))
|
||||
|
|
@ -9258,7 +9268,7 @@
|
|||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
[b (a) #:lazy (>=/c (+ a 1))]))
|
||||
|
||||
(s-b (contract (g 10)
|
||||
(s 12 14)
|
||||
|
|
@ -9275,7 +9285,7 @@
|
|||
(define-opt/c (g z)
|
||||
(struct/dc s
|
||||
[a (>=/c z)]
|
||||
[b #:lazy (a) (>=/c (+ a 1))]))
|
||||
[b (a) #:lazy (>=/c (+ a 1))]))
|
||||
|
||||
(s-b (contract (g 11)
|
||||
(s 12 10)
|
||||
|
|
@ -9291,7 +9301,7 @@
|
|||
(or/c not
|
||||
(struct/dc kons
|
||||
[hd (unknown-function a)]
|
||||
[tl #:lazy () (or/c #f (f b a))])))
|
||||
[tl () #:lazy (or/c #f (f b a))])))
|
||||
(kons-hd (kons-tl (contract (f 1 2)
|
||||
(kons 1 (kons 2 #f))
|
||||
'pos
|
||||
|
|
@ -9344,7 +9354,7 @@
|
|||
(struct s (q a))
|
||||
(contract (struct/dc s
|
||||
[q integer?]
|
||||
[a #:lazy (q) (<=/c a)])
|
||||
[a (q) #:lazy (<=/c q)])
|
||||
(s 1 #f)
|
||||
'pos
|
||||
'neg)))
|
||||
|
|
@ -9367,6 +9377,44 @@
|
|||
(struct/dc s [a (new-∃/c 'α)]))
|
||||
exn:fail?)
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new1
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s [a integer?]) (s #f) 'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new2
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new3
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (s-a (struct/dc s [a #:lazy integer?])) (s #f) 'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new4
|
||||
'(let ()
|
||||
(struct s ([a #:mutable]))
|
||||
(contract (struct/dc s [a integer?]) (s #f) 'pos 'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new5
|
||||
'(let ()
|
||||
(struct s ([a #:mutable]))
|
||||
(contract (s-a (struct/dc s [a integer?])) (s #f) 'pos 'neg)))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new6
|
||||
'(let ()
|
||||
(struct s ([a #:mutable]))
|
||||
(set-s-a! (contract (struct/dc s [a integer?]) (s 1) 'pos 'neg)
|
||||
#f)))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -10552,18 +10600,17 @@ so that propagation occurs.
|
|||
(ctest #t chaperone-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b integer?])))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(ctest #t flat-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b integer?])))
|
||||
(ctest #f flat-contract? (let ()
|
||||
(ctest #t flat-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
|
||||
|
||||
(test-flat-contract '(and/c number? integer?) 1 3/2)
|
||||
|
||||
(test-flat-contract '(not/c integer?) #t 1)
|
||||
(test-flat-contract '(=/c 2) 2 3)
|
||||
(test-flat-contract '(>/c 5) 10 5)
|
||||
|
|
@ -12062,6 +12109,24 @@ so that propagation occurs.
|
|||
(letrec ([f (λ (x) 'not-f)])
|
||||
((contract ctc f 'pos 'neg) 1)))))
|
||||
|
||||
(ctest '("the a field of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (b) (<=/c b)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(ctest '("the a field of")
|
||||
extract-context-lines
|
||||
(λ ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (<=/c 1)] [b integer?])
|
||||
(s 2 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
#;
|
||||
(ctest '("an element of" "the 3rd element of")
|
||||
extract-context-lines
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user