finish up struct/dc
This commit is contained in:
Robby Findler
parent
64603d0c27
commit
5996e8f480
|
|
@ -158,37 +158,30 @@
|
|||
;; opt/unknown : opt/i id id syntax
|
||||
;;
|
||||
(define (opt/unknown opt/i opt/info uctc)
|
||||
(let* ((lift-var (car (generate-temporaries (syntax (lift)))))
|
||||
(partial-var (car (generate-temporaries (syntax (partial)))))
|
||||
(partial-flat-var (car (generate-temporaries (syntax (partial-flat))))))
|
||||
(with-syntax ([(lift-var partial-var partial-flat-var)
|
||||
(generate-temporaries '(lift partial partial-flat))]
|
||||
[val (opt/info-val opt/info)]
|
||||
[uctc uctc]
|
||||
[blame (opt/info-blame opt/info)])
|
||||
(values
|
||||
(with-syntax ((partial-var partial-var)
|
||||
(lift-var lift-var)
|
||||
(uctc uctc)
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (partial-var val)))
|
||||
(list (cons lift-var
|
||||
;; FIXME needs to get the contract name somehow
|
||||
(with-syntax ((uctc uctc))
|
||||
(syntax (coerce-contract 'opt/c uctc)))))
|
||||
#'(partial-var val)
|
||||
(list (cons #'lift-var
|
||||
#'(coerce-contract 'opt/c uctc)))
|
||||
null
|
||||
(list (cons
|
||||
partial-var
|
||||
(with-syntax ((lift-var lift-var)
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax ((contract-projection lift-var) blame))))
|
||||
#'partial-var
|
||||
#'((contract-projection lift-var) blame))
|
||||
(cons
|
||||
partial-flat-var
|
||||
(with-syntax ((lift-var lift-var))
|
||||
(syntax (if (flat-contract? lift-var)
|
||||
(flat-contract-predicate lift-var)
|
||||
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
|
||||
lift-var
|
||||
x)))))))
|
||||
#'partial-flat-var
|
||||
#'(if (flat-contract? lift-var)
|
||||
(flat-contract-predicate lift-var)
|
||||
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
|
||||
lift-var
|
||||
x)))))
|
||||
#f
|
||||
lift-var
|
||||
#'lift-var
|
||||
null
|
||||
#`(chaperone-contract? #,lift-var))))
|
||||
#'(chaperone-contract? lift-var))))
|
||||
|
||||
;; combine-two-chaperone?s : (or/c boolean? syntax?) (or/c boolean? syntax?) -> (or/c boolean? syntax?)
|
||||
(define (combine-two-chaperone?s chaperone-a? chaperone-b?)
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
(for-syntax "opt-guts.rkt")
|
||||
(for-syntax racket/stxparam))
|
||||
|
||||
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref
|
||||
(provide opt/c define-opt/c define/opter
|
||||
opt/direct
|
||||
begin-lifted)
|
||||
|
||||
|
|
@ -338,6 +338,9 @@
|
|||
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
|
||||
(make-struct-type-property 'original-contract))
|
||||
|
||||
;; the stronger-vars don't seem to be used anymore for stronger; probably
|
||||
;; they should be folded into the lifts and then there should be a separate
|
||||
;; setup for consolidating stronger checks
|
||||
(define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp chaperone?)
|
||||
#:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
|
||||
#:property prop:opt-chaperone-contract (λ (ctc) (opt-contract-chaperone? ctc))
|
||||
|
|
@ -350,8 +353,3 @@
|
|||
(and (opt-contract? that)
|
||||
(eq? (opt-contract-stamp this) (opt-contract-stamp that))
|
||||
((opt-contract-stronger this) this that)))))
|
||||
|
||||
;; opt-stronger-vars-ref : int opt-contract -> any
|
||||
(define (opt-stronger-vars-ref i ctc)
|
||||
(let ((v (opt-contract-stronger-vars ctc)))
|
||||
(vector-ref v i)))
|
||||
|
|
|
|||
|
|
@ -63,7 +63,6 @@
|
|||
[else
|
||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
|
||||
(opt/i opt/info (car ps))])
|
||||
(define next-chaperone? (combine-two-chaperone?s chaperone? this-chaperone?))
|
||||
(if flat
|
||||
(loop (cdr ps)
|
||||
(cons flat next-ps)
|
||||
|
|
@ -73,7 +72,7 @@
|
|||
(append this-stronger-ribs stronger-ribs)
|
||||
hos
|
||||
ho-ctc
|
||||
next-chaperone?)
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?))
|
||||
(if (< (length hos) 1)
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
|
|
@ -83,7 +82,7 @@
|
|||
(append this-stronger-ribs stronger-ribs)
|
||||
(cons (car ps) hos)
|
||||
next
|
||||
next-chaperone?)
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?))
|
||||
(loop (cdr ps)
|
||||
next-ps
|
||||
lift-ps
|
||||
|
|
@ -92,7 +91,7 @@
|
|||
stronger-ribs
|
||||
(cons (car ps) hos)
|
||||
ho-ctc
|
||||
next-chaperone?))))]))])
|
||||
chaperone?))))]))])
|
||||
(with-syntax ((next-ps
|
||||
(with-syntax (((opt-p ...) (reverse opt-ps)))
|
||||
(syntax (or opt-p ...)))))
|
||||
|
|
@ -409,14 +408,15 @@
|
|||
(loop (cdr vars)
|
||||
(cdr doms)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(car-vars (car vars))
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-doms)
|
||||
(append lifts-doms lift)
|
||||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and chaperone? this-chaperone?)))]))]
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))]
|
||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?)
|
||||
(let loop ([vars rng-vars]
|
||||
[rngs rngs]
|
||||
|
|
@ -439,16 +439,18 @@
|
|||
(loop (cdr vars)
|
||||
(cdr rngs)
|
||||
(cons (with-syntax ((next next)
|
||||
(car-vars (car vars)))
|
||||
(car-vars (car vars))
|
||||
(val (opt/info-val opt/info)))
|
||||
(syntax (let ((val car-vars)) next)))
|
||||
next-rngs)
|
||||
(append lifts-rngs lift)
|
||||
(append superlifts-rngs superlift)
|
||||
(append partials-rngs partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and chaperone? this-chaperone?)))]))])
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((rng-arg ...) rng-vars)
|
||||
((next-dom ...) next-doms)
|
||||
|
|
@ -476,7 +478,7 @@
|
|||
#f
|
||||
#f
|
||||
(append stronger-ribs-dom stronger-ribs-rng)
|
||||
(and dom-chaperone? rng-chaperone?))))
|
||||
(combine-two-chaperone?s dom-chaperone? rng-chaperone?))))
|
||||
|
||||
(define (opt/arrow-any-ctc doms)
|
||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
||||
|
|
@ -509,7 +511,7 @@
|
|||
(append superlifts-doms superlift)
|
||||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)
|
||||
(and chaperone? this-chaperone?)))]))])
|
||||
(combine-two-chaperone?s chaperone? this-chaperone?)))]))])
|
||||
(values
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3,7 +3,7 @@
|
|||
;; 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 (top-sort elements neighbors fail)
|
||||
(define parents (make-hash))
|
||||
(define children (make-hash))
|
||||
(define ids (make-hash))
|
||||
|
|
@ -54,6 +54,6 @@
|
|||
(cons best (loop))])))
|
||||
|
||||
(cond
|
||||
[(zero? (hash-count pending)) sorted]
|
||||
[else #f]))
|
||||
[(= (length sorted) (length elements)) sorted]
|
||||
[else (fail (remove* sorted elements))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -393,35 +393,39 @@ produced. Otherwise, an impersonator contract is produced.
|
|||
([field-spec [field-id maybe-lazy contract-expr]
|
||||
[field-id (dep-field-id ...)
|
||||
maybe-lazy
|
||||
maybe-flat
|
||||
maybe-flat-or-impersonator
|
||||
maybe-dep-state
|
||||
contract-expr]]
|
||||
[maybe-lazy (code:line) #:lazy]
|
||||
[maybe-flat (code:line) #:flat]
|
||||
[maybe-flat-or-impersonator (code:line) #:flat #:impersonator]
|
||||
[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,
|
||||
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].
|
||||
a chaperone, but not always a flat contract (and theus the entire @racket[struct/dc]
|
||||
contract is not a flat contract).
|
||||
If this is not the case, and the contract is
|
||||
always flat then the field must be annotated with
|
||||
the @racket[#:flat], or the field must be annotated with
|
||||
@racket[#:chaperone] (in which case, it must be a mutable field).
|
||||
|
||||
If the @racket[#:lazy] keyword appears, then the contract
|
||||
on the field is check lazily (only when a selector is applied);
|
||||
@racket[#:lazy] contracts cannot be put on mutable fields.
|
||||
|
||||
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).
|
||||
field). Otherwise, the contract expression for a dependent field contract
|
||||
is evaluated when the contract is applied to a value.
|
||||
|
||||
Contracts for immutable fields must be either flat or chaperone contracts.
|
||||
Contracts for mutable fields may be impersonator contracts.
|
||||
|
|
@ -433,14 +437,17 @@ produced. Otherwise, an impersonator contract is produced.
|
|||
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].
|
||||
The lazy annotations ensure that this contract does not
|
||||
change the running time of operations that do not
|
||||
inspect the entire tree.
|
||||
|
||||
@racketblock[(struct bt (val left right))
|
||||
(define (bst/c lo hi)
|
||||
(or/c #f
|
||||
(struct/dc bt
|
||||
[val (between/c lo hi)]
|
||||
[left (val) (bst lo val)]
|
||||
[right (val) (bst val hi)])))]
|
||||
[left (val) #:lazy (bst lo val)]
|
||||
[right (val) #:lazy (bst val hi)])))]
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -9402,7 +9402,7 @@
|
|||
'struct/dc-new3
|
||||
'(let ()
|
||||
(struct s (a))
|
||||
(contract (s-a (struct/dc s [a #:lazy integer?])) (s #f) 'pos 'neg)))
|
||||
(s-a (contract (struct/dc s [a #:lazy integer?]) (s #f) 'pos 'neg))))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new4
|
||||
|
|
@ -9414,7 +9414,7 @@
|
|||
'struct/dc-new5
|
||||
'(let ()
|
||||
(struct s ([a #:mutable]))
|
||||
(contract (s-a (struct/dc s [a integer?])) (s #f) 'pos 'neg)))
|
||||
(s-a (contract (struct/dc s [a integer?]) (s #f) 'pos 'neg))))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new6
|
||||
|
|
@ -9423,6 +9423,460 @@
|
|||
(set-s-a! (contract (struct/dc s [a integer?]) (s 1) 'pos 'neg)
|
||||
#f)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new7
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b) (<=/c (car b))])
|
||||
(s 3 '(2) 1)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new8
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (a b) (and/c (<=/c a) (<=/c (car b)))])
|
||||
(s 3 '(2) 1)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new9
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a any/c] [b (a) (non-empty-listof real?)] [c (b a) (and/c (<=/c a) (<=/c (car b)))])
|
||||
(s 3 '(2) 1)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new10
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a (b) (<=/c (car b))] [b (c) (non-empty-listof real?)] [c real?])
|
||||
(s 1 '(2) 3)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new11
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a (b c) (and/c (<=/c (car b)) (<=/c c))] [b (c) (non-empty-listof real?)] [c real?])
|
||||
(s 1 '(2) 3)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new12
|
||||
'(let ()
|
||||
(struct s (a b c))
|
||||
(s-c (contract (struct/dc s [a (c b) (and/c (<=/c (car b)) (<=/c c))] [b (c) (non-empty-listof real?)] [c real?])
|
||||
(s 1 '(2) 3)
|
||||
'pos
|
||||
'neg))))
|
||||
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new13
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f 1))])
|
||||
(s (λ (x) #f) 123)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/dc-new14
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f (-> integer? integer?)] [b (f) (<=/c (f #f))])
|
||||
(s (λ (x) 1) 123)
|
||||
'pos
|
||||
'neg))
|
||||
"top-level")
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new15
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))])
|
||||
(s (λ (x) #f) 123)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/dc-new16
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))])
|
||||
(s (λ (x) 1) 123)
|
||||
'pos
|
||||
'neg))
|
||||
"top-level")
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new17
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f 1))])
|
||||
(s (λ (x) #f) 123)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/dc-new18
|
||||
'(let ()
|
||||
(struct s (f b))
|
||||
(contract (struct/dc s [f #:lazy (-> integer? integer?)] [b (f) #:lazy (<=/c (f #f))])
|
||||
(s (λ (x) 1) 123)
|
||||
'pos
|
||||
'neg))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new19
|
||||
'(let ()
|
||||
(struct s (a b c d))
|
||||
(contract (struct/dc s
|
||||
[a integer?]
|
||||
[b #:lazy symbol?]
|
||||
[c (a) boolean?]
|
||||
[d (a c) integer?])
|
||||
(s 1 'x #t 5)
|
||||
'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new20
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable] c [d #:mutable]))
|
||||
(contract (struct/dc s
|
||||
[a integer?]
|
||||
[b symbol?]
|
||||
[c (a) boolean?]
|
||||
[d (a c) integer?])
|
||||
(s 1 'x #t 5)
|
||||
'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new21
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a integer?] [b boolean?])
|
||||
(s 1 #f)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s 2)))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new22
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a integer?] [b boolean?])
|
||||
(s 1 #f)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s #f)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new22
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(contract (struct/dc s [a integer?] [b boolean?])
|
||||
(s 'one #f)
|
||||
'pos 'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new23
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(s-a (contract (struct/dc s [a integer?] [b boolean?])
|
||||
(s 'one #f)
|
||||
'pos 'neg))))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new24
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?])
|
||||
(s (λ (x) #f) #f)
|
||||
'pos 'neg))
|
||||
((s-a an-s) 1)))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new25
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a (-> integer? integer?)] [b boolean?])
|
||||
(s (λ (x) #f) #f)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) #f))
|
||||
((s-a an-s) 1)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new26
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))])
|
||||
(s (λ (x) #f) #f)
|
||||
'pos 'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new27
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))])
|
||||
(s (λ (x) 1) 1)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) -2))
|
||||
(s-b an-s)))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new28
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s [a (-> integer? integer?)] [b (a) (<=/c (a 1))])
|
||||
(s (λ (x) 1) 1)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) #f))
|
||||
(s-b an-s)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new29
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b c))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a (-> integer? integer?)]
|
||||
[b (a) (<=/c (a 1))]
|
||||
[c (b) (<=/c b)])
|
||||
(s (λ (x) 1) -11 1)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) -2))
|
||||
(s-c an-s)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new30
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b c))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a (-> integer? integer?)]
|
||||
[b (a) (<=/c (a 1))]
|
||||
[c (b) (<=/c b)])
|
||||
(s (λ (x) 1) 1 -2)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) -2))
|
||||
(s-c an-s)))
|
||||
|
||||
(test/neg-blame
|
||||
'struct/dc-new31
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] [b #:mutable]))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a (-> integer? integer?)]
|
||||
[b (a) (<=/c (a 1))])
|
||||
(s (λ (x) 1) 1)
|
||||
'pos 'neg))
|
||||
(set-s-b! an-s 3)))
|
||||
|
||||
(test/pos-blame
|
||||
'struct/dc-new32
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] [b #:mutable]))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a (-> integer? integer?)]
|
||||
[b (a) (<=/c (a 1))])
|
||||
(s (λ (x) 1) 1)
|
||||
'pos 'neg))
|
||||
(set-s-a! an-s (λ (x) -1))
|
||||
(s-b an-s)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/dc-new33
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable] [c #:mutable]))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a (-> integer? integer?)]
|
||||
[b any/c]
|
||||
[c (a b) (<=/c (a b))])
|
||||
(s (λ (x) 1) 1 1)
|
||||
'pos 'neg))
|
||||
(set-s-b! an-s #f)
|
||||
(s-c an-s))
|
||||
"top-level")
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-new-34
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] [b #:mutable]))
|
||||
(contract (struct/dc s
|
||||
[a boolean?]
|
||||
[b (a)
|
||||
#:flat
|
||||
(if a
|
||||
(<=/c 1)
|
||||
(-> integer? integer?))])
|
||||
(s #f 1)
|
||||
'pos
|
||||
'neg))
|
||||
(λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x))))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-new-35
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] [b #:mutable]))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a boolean?]
|
||||
[b (a)
|
||||
#:flat
|
||||
(if a
|
||||
(<=/c 1)
|
||||
(-> integer? integer?))])
|
||||
(s #t 1)
|
||||
'pos
|
||||
'neg))
|
||||
(set-s-a! an-s #f)
|
||||
(s-b an-s))
|
||||
(λ (x) (regexp-match #rx"struct/dc: .*flat" (exn-message x))))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-new-36
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(contract (struct/dc s
|
||||
[a boolean?]
|
||||
[b (a)
|
||||
(if a
|
||||
(<=/c 1)
|
||||
(new-∃/c 'α))])
|
||||
(s #f 1)
|
||||
'pos
|
||||
'neg))
|
||||
(λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x))))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-new-37
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a boolean?]
|
||||
[b (a)
|
||||
(if a
|
||||
(<=/c 1)
|
||||
(new-∃/c 'α))])
|
||||
(s #t 1)
|
||||
'pos
|
||||
'neg))
|
||||
(set-s-a! an-s #f)
|
||||
(s-b an-s))
|
||||
(λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x))))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-new-38
|
||||
'(let ()
|
||||
(struct s ([a #:mutable] b [c #:mutable]))
|
||||
(define an-s (contract (struct/dc s
|
||||
[a boolean?]
|
||||
[b (a)
|
||||
(if a
|
||||
(<=/c 1)
|
||||
(new-∃/c 'α))]
|
||||
[c (b) integer?])
|
||||
(s #t 1 1)
|
||||
'pos
|
||||
'neg))
|
||||
(set-s-a! an-s #f)
|
||||
(s-c an-s))
|
||||
(λ (x) (regexp-match #rx"struct/dc: .*chaperone" (exn-message x))))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new-39
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a integer?] [b integer?]) (s 1 2) 'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new40
|
||||
'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a (-> integer? integer?)] [b (-> integer? integer?)])
|
||||
(s (λ (x) x) (λ (y) y))
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-new41
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(define α (new-∀/c 'α))
|
||||
(s-b ((contract (-> α (struct/dc s [b α]))
|
||||
(λ (x) (s 11 x))
|
||||
'pos
|
||||
'neg) 1)))
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/dc-new42
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(define α (new-∀/c 'α))
|
||||
(s-b ((contract (-> α (struct/dc s [a integer?] [b (a) #:impersonator α]))
|
||||
(λ (x) (s 11 x))
|
||||
'pos
|
||||
'neg) 1)))
|
||||
1)
|
||||
|
||||
(test/spec-passed
|
||||
'struct/dc-new42
|
||||
'(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(contract (struct/dc s [a (-> integer? integer?)] [b (new-∀/c 'α)])
|
||||
(s (λ (x) x) 1)
|
||||
'pos
|
||||
'neg)))
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-not-a-field
|
||||
#'(eval '(let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [y integer?])))
|
||||
exn:fail:syntax?)
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-circular-dependecies1
|
||||
#'(eval '(let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a (a) integer?] [b (a) integer?])))
|
||||
exn:fail:syntax?)
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-circular-dependecies2
|
||||
#'(eval '(let ()
|
||||
(struct s (a b c))
|
||||
(struct/dc s [a (b) integer?] [b (a) integer?] [c integer?])))
|
||||
exn:fail:syntax?)
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-dep-on-lazy
|
||||
#'(eval '(let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a #:lazy integer?] [b (a) integer?])))
|
||||
exn:fail:syntax?)
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-lazy-mutable
|
||||
#'(eval '(let ()
|
||||
(struct s (a [b #:mutable]))
|
||||
(struct/dc s [a integer?] [b #:lazy integer?])))
|
||||
exn:fail:syntax?)
|
||||
|
||||
(contract-error-test
|
||||
'struct/dc-immutable-impersonator
|
||||
#'(eval '(let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) #:impersonator (<=/c a)])))
|
||||
(λ (x) (and (exn:fail:syntax? x) (regexp-match #rx"immutable" (exn-message x)))))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -10485,9 +10939,11 @@ so that propagation occurs.
|
|||
(define alpha (new-∃/c 'alpha))
|
||||
(struct/c s alpha)))
|
||||
|
||||
(ctest #t (chaperone-contract?
|
||||
(let ([x (struct/dc s [a integer?] [b integer?])])
|
||||
(opt/c x))))
|
||||
(ctest #t chaperone-contract?
|
||||
(let ()
|
||||
(struct s (a b))
|
||||
(let ([x (struct/dc s [a integer?] [b integer?])])
|
||||
(opt/c x))))
|
||||
|
||||
(ctest #t flat-contract? (set/c integer?))
|
||||
(ctest #f flat-contract? (set/c (-> integer? integer?)))
|
||||
|
|
@ -10618,7 +11074,16 @@ so that propagation occurs.
|
|||
(struct/dc s [a integer?] [b integer?])))
|
||||
(ctest #t flat-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
(struct/dc s [a integer?] [b (a) #:flat (>=/c a)])))
|
||||
(contract-error-test
|
||||
'struct/dc-not-really-flat-dep-field
|
||||
#'(let ()
|
||||
(struct s (a b))
|
||||
(contract (struct/dc s [a integer?] [b (a) #:flat (-> integer? integer?)])
|
||||
(s 1 (λ (x) x))
|
||||
'pos
|
||||
'neg))
|
||||
exn:fail?)
|
||||
(ctest #t chaperone-contract? (let ()
|
||||
(struct s (a b))
|
||||
(struct/dc s [a integer?] [b (a) (>=/c a)])))
|
||||
|
|
@ -11086,17 +11551,30 @@ so that propagation occurs.
|
|||
|
||||
(test-name '(struct/dc s
|
||||
[a integer?]
|
||||
[b #:lazy symbol?]
|
||||
[b symbol?]
|
||||
[c (a b) ...]
|
||||
[d (a b c) ...])
|
||||
(let ()
|
||||
(struct s (a b c d))
|
||||
(struct/dc s
|
||||
[a integer?]
|
||||
[b #:lazy symbol?]
|
||||
[b symbol?]
|
||||
[c (a b) boolean?]
|
||||
[d (a b c) integer?])))
|
||||
|
||||
(test-name '(struct/dc s
|
||||
[a integer?]
|
||||
[b #:lazy symbol?]
|
||||
[c (a) ...]
|
||||
[d (a c) ...])
|
||||
(let ()
|
||||
(struct s (a b c d))
|
||||
(struct/dc s
|
||||
[a integer?]
|
||||
[b #:lazy symbol?]
|
||||
[c (a) boolean?]
|
||||
[d (a c) integer?])))
|
||||
|
||||
;; NOT YET RELEASED
|
||||
#;
|
||||
(test-name '(pr/dc [x integer?]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user