added list-contract?
and specialized a bunch of list-related contracts to track list?-ness, notably recursive-contract now accepts a #:list-contract? argument that means that it insists that values it accepts be list? (and thus not cyclic) related to PR 14559
This commit is contained in:
Robby Findler
parent
0db4df1d33
commit
f49dd363fa
|
|
@ -187,6 +187,9 @@ For example, this contract
|
|||
does not accept a function like this one: @racket[(lambda args ...)]
|
||||
since it cannot tell which of the two arrow contracts should be used
|
||||
with the function.
|
||||
|
||||
If all of its arguments are @racket[list-contract?]s, then @racket[or/c]
|
||||
returns a @racket[list-contract?].
|
||||
}
|
||||
|
||||
@defproc[(and/c [contract contract?] ...) contract?]{
|
||||
|
|
@ -369,14 +372,14 @@ Returns the same contract as @racket[(box/c c #:immutable #t)]. This form exists
|
|||
reasons of backwards compatibility.}
|
||||
|
||||
|
||||
@defproc[(listof [c contract?]) contract?]{
|
||||
@defproc[(listof [c contract?]) list-contract?]{
|
||||
|
||||
Returns a contract that recognizes a list whose every element matches
|
||||
the contract @racket[c]. Beware that when this contract is applied to
|
||||
a value, the result is not necessarily @racket[eq?] to the input.}
|
||||
|
||||
|
||||
@defproc[(non-empty-listof [c contract?]) contract?]{
|
||||
@defproc[(non-empty-listof [c contract?]) list-contract?]{
|
||||
|
||||
Returns a contract that recognizes non-empty lists whose elements match
|
||||
the contract @racket[c]. Beware that when this contract is applied to
|
||||
|
|
@ -387,10 +390,16 @@ a value, the result is not necessarily @racket[eq?] to the input.}
|
|||
Produces a contract that recognizes pairs whose first and second elements
|
||||
match @racket[car-c] and @racket[cdr-c], respectively. Beware that
|
||||
when this contract is applied to a value, the result is not
|
||||
necessarily @racket[eq?] to the input.}
|
||||
necessarily @racket[eq?] to the input.
|
||||
|
||||
If the @racket[cdr-c] contract is a @racket[list-contract?], then
|
||||
@racket[cons/c] returns a @racket[list-contract?].
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[list-contract?] propagating behavior.}]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(list/c [c contract?] ...) contract?]{
|
||||
@defproc[(list/c [c contract?] ...) list-contract?]{
|
||||
|
||||
Produces a contract for a list. The number of elements in the list
|
||||
must match the number of arguments supplied to @racket[list/c], and
|
||||
|
|
@ -1858,7 +1867,8 @@ the contract library primitives below.
|
|||
name x))))]
|
||||
[#:stronger stronger
|
||||
(or/c #f (-> contract? contract? boolean?))
|
||||
#f])
|
||||
#f]
|
||||
[#:list-contract is-list-contract? boolean? #f])
|
||||
contract?]
|
||||
@defproc[(make-chaperone-contract
|
||||
[#:name name any/c 'anonymous-chaperone-contract]
|
||||
|
|
@ -1878,7 +1888,8 @@ the contract library primitives below.
|
|||
name x))))]
|
||||
[#:stronger stronger
|
||||
(or/c #f (-> contract? contract? boolean?))
|
||||
#f])
|
||||
#f]
|
||||
[#:list-contract is-list-contract? boolean? #f])
|
||||
chaperone-contract?]
|
||||
@defproc[(make-flat-contract
|
||||
[#:name name any/c 'anonymous-flat-contract]
|
||||
|
|
@ -1898,7 +1909,8 @@ the contract library primitives below.
|
|||
name x))))]
|
||||
[#:stronger stronger
|
||||
(or/c #f (-> contract? contract? boolean?))
|
||||
#f])
|
||||
#f]
|
||||
[#:list-contract is-list-contract? boolean? #f])
|
||||
flat-contract?]
|
||||
)]{
|
||||
|
||||
|
|
@ -1946,6 +1958,9 @@ The @racket[stronger] argument is used to implement @racket[contract-stronger?].
|
|||
first argument is always the contract itself and the second argument is whatever
|
||||
was passed as the second argument to @racket[contract-stronger?].
|
||||
|
||||
The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate
|
||||
to determine if this is a contract that accepts only @racket[list?] values.
|
||||
|
||||
@defexamples[#:eval (contract-eval)
|
||||
(define int/c
|
||||
(make-flat-contract #:name 'int/c #:first-order integer?))
|
||||
|
|
@ -1977,6 +1992,7 @@ was passed as the second argument to @racket[contract-stronger?].
|
|||
(halve 1)
|
||||
]
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
|
||||
}
|
||||
|
||||
@defproc[(build-compound-type-name [c/s any/c] ...) any]{
|
||||
|
|
@ -2306,7 +2322,8 @@ is expected to be the blame record for the contract on the value).
|
|||
(-> (and/c positive? real?)
|
||||
(values
|
||||
(-> c void?)
|
||||
(listof contract?)))]))])
|
||||
(listof contract?)))]))]
|
||||
[#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
|
||||
flat-contract-property?]
|
||||
@defproc[(build-chaperone-contract-property
|
||||
[#:name
|
||||
|
|
@ -2353,7 +2370,8 @@ is expected to be the blame record for the contract on the value).
|
|||
(-> (and/c positive? real?)
|
||||
(values
|
||||
(-> c void?)
|
||||
(listof contract?)))]))])
|
||||
(listof contract?)))]))]
|
||||
[#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
|
||||
chaperone-contract-property?]
|
||||
@defproc[(build-contract-property
|
||||
[#:name
|
||||
|
|
@ -2400,7 +2418,8 @@ is expected to be the blame record for the contract on the value).
|
|||
(-> (and/c positive? real?)
|
||||
(values
|
||||
(-> c void?)
|
||||
(listof contract?)))]))])
|
||||
(listof contract?)))]))]
|
||||
[#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
|
||||
contract-property?])]{
|
||||
|
||||
@italic{The precise details of the
|
||||
|
|
@ -2423,10 +2442,12 @@ produces a blame-tracking projection defining the behavior of the contract;
|
|||
(passed in the first argument) is stronger than some other contract (passed
|
||||
in the second argument); @racket[generate], which returns a thunk
|
||||
that generates random values matching the contract or @racket[#f], indicating
|
||||
that random generation for this contract isn't supported; and @racket[exercise],
|
||||
that random generation for this contract isn't supported; @racket[exercise],
|
||||
which returns a function that exercises values matching the contract (e.g.,
|
||||
if it is a function contract, it may call the function) and a list of contracts
|
||||
whose values will be generated by this process.
|
||||
whose values will be generated by this process; and @racket[is-flat-contract?],
|
||||
which is used by @racket[flat-contract?] to determine if this contract
|
||||
accepts only @racket[list?]s.
|
||||
|
||||
These accessors are passed as (optional) keyword arguments to
|
||||
@racket[build-contract-property], and are applied to instances of the
|
||||
|
|
@ -2448,6 +2469,7 @@ projection accessor is expected not to wrap its argument in a higher-order
|
|||
fashion, analogous to the constraint on projections in
|
||||
@racket[make-flat-contract].
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
|
|
@ -2628,6 +2650,17 @@ symbols, booleans, numbers, and other ordinary Racket values
|
|||
(that are defined as @tech{contracts}) are also
|
||||
flat contracts.}
|
||||
|
||||
@defproc[(list-contract? [v any/c]) boolean?]{
|
||||
Recognizes certain @racket[contract?] values that accept @racket[list?]s.
|
||||
|
||||
A list contract is one that insists that its argument
|
||||
is a @racket[list?], meaning that the value cannot be cyclic
|
||||
and must either be the empty list or a pair constructed
|
||||
with @racket[cons] and another list.
|
||||
|
||||
@history[#:added "6.0.1.13"]
|
||||
}
|
||||
|
||||
@defproc[(contract-name [c contract?]) any/c]{
|
||||
Produces the name used to describe the contract in error messages.
|
||||
}
|
||||
|
|
@ -2670,13 +2703,22 @@ Makes a contract that accepts no values, and reports the
|
|||
name @racket[sexp-name] when signaling a contract violation.}
|
||||
|
||||
@defform*[[(recursive-contract contract-expr)
|
||||
(recursive-contract contract-expr type)]]{
|
||||
(recursive-contract contract-expr #:list-contract?)
|
||||
(recursive-contract contract-expr type)
|
||||
(recursive-contract contract-expr type #:list-contract?)]]{
|
||||
|
||||
Delays the evaluation of its argument until the contract is checked,
|
||||
making recursive contracts possible. If @racket[type] is given, it
|
||||
describes the expected type of contract and must be one of the keywords
|
||||
@racket[#:impersonator], @racket[#:chaperone], or @racket[#:flat]. If
|
||||
@racket[type] is not given, an impersonator contract is created.}
|
||||
@racket[type] is not given, an impersonator contract is created.
|
||||
|
||||
If @racket[#:list-contract?] is returned, then the result is a
|
||||
@racket[list-contract?] and the @racket[contract-expr] must evaluate
|
||||
to a @racket[list-contract?].
|
||||
|
||||
@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
|
||||
}
|
||||
|
||||
|
||||
@defform/subs[(opt/c contract-expr maybe-name)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,114 @@
|
|||
#lang racket/base
|
||||
(require "test-util.rkt")
|
||||
(parameterize ([current-contract-namespace (make-basic-contract-namespace 'racket/list)])
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-1
|
||||
'(list-contract? 1)
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-2
|
||||
'(list-contract? (λ (a b c) a)) ;; somethign that's not coerceable to a contract
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-3
|
||||
'(list-contract? '())
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-4
|
||||
'(list-contract? null?)
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-5
|
||||
'(list-contract? empty?)
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-6
|
||||
'(list-contract? boolean?)
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-7
|
||||
'(list-contract? any/c)
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-8
|
||||
'(list-contract? (cons/c 1 empty?))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-9
|
||||
'(list-contract? (cons/c 1 2))
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-10
|
||||
'(list-contract? (listof any/c))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-11
|
||||
'(list-contract? (non-empty-listof any/c))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-12
|
||||
'(list-contract? (list/c 1 2 3))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-13
|
||||
'(list-contract? (or/c (cons/c 1 empty?) empty?))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-14
|
||||
'(list-contract? (or/c (cons/c (-> integer? integer?) empty?)
|
||||
empty?))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-15
|
||||
'(list-contract? (or/c (cons/c (-> integer? integer?) empty?)
|
||||
(cons/c (-> integer? integer? integer?) empty?)
|
||||
empty?))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-16
|
||||
'(list-contract?
|
||||
(letrec ([c (recursive-contract (or/c (cons/c 1 c) empty?))])
|
||||
c))
|
||||
#f)
|
||||
|
||||
(test/spec-passed/result
|
||||
'list-contract-17
|
||||
'(list-contract?
|
||||
(letrec ([c (recursive-contract (or/c (cons/c 1 c) empty?) #:list-contract?)])
|
||||
c))
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
'test-contract-18
|
||||
'(contract (letrec ([c (recursive-contract (or/c (cons/c any/c c) empty?)
|
||||
#:list-contract?)])
|
||||
c)
|
||||
(read (open-input-string "#1=(1 . #1#)"))
|
||||
'pos 'neg))
|
||||
|
||||
|
||||
(contract-error-test
|
||||
'test-contract-19
|
||||
'(contract (recursive-contract 1 #:list-contract?)
|
||||
1
|
||||
'pos 'neg)
|
||||
(λ (x)
|
||||
(and (exn:fail? x)
|
||||
(regexp-match #rx"list-contract[?]" (exn-message x))))))
|
||||
|
||||
|
|
@ -67,6 +67,7 @@
|
|||
has-blame?
|
||||
value-blame
|
||||
contract-continuation-mark-key
|
||||
list-contract?
|
||||
|
||||
;; from private/case-arrow.rkt
|
||||
case->)
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@
|
|||
'#,(build-source-location-vector #'ctc))))]))
|
||||
|
||||
(define-syntax (-recursive-contract stx)
|
||||
(define (do-recursive-contract arg type name)
|
||||
(define (do-recursive-contract arg type name list-contract?)
|
||||
(define local-name (syntax-local-infer-name stx))
|
||||
(define maker
|
||||
(case (syntax-e type)
|
||||
|
|
@ -115,13 +115,18 @@
|
|||
"type must be one of #:impersonator, #:chaperone, or #:flat"
|
||||
stx
|
||||
type)]))
|
||||
#`(#,maker '#,name (λ () #,arg) '#,local-name))
|
||||
#`(#,maker '#,name (λ () #,arg) '#,local-name #,list-contract?))
|
||||
(syntax-case stx ()
|
||||
[(_ arg type #:list-contract?)
|
||||
(keyword? (syntax-e #'type))
|
||||
(do-recursive-contract #'arg #'type #'(recursive-contract arg type) #t)]
|
||||
[(_ arg #:list-contract?)
|
||||
(do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg) #t)]
|
||||
[(_ arg type)
|
||||
(keyword? (syntax-e #'type))
|
||||
(do-recursive-contract #'arg #'type #'(recursive-contract arg type))]
|
||||
(do-recursive-contract #'arg #'type #'(recursive-contract arg type) #f)]
|
||||
[(_ arg)
|
||||
(do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg))]))
|
||||
(do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg) #f)]))
|
||||
|
||||
(define (force-recursive-contract ctc)
|
||||
(define current (recursive-contract-ctc ctc))
|
||||
|
|
@ -138,19 +143,37 @@
|
|||
(coerce-chaperone-contract 'recursive-contract (thunk))]
|
||||
[(impersonator-recursive-contract? ctc)
|
||||
(coerce-contract 'recursive-contract (thunk))]))
|
||||
(when (recursive-contract-list-contract? ctc)
|
||||
(unless (list-contract? forced-ctc)
|
||||
(raise-argument-error 'recursive-contract "list-contract?" forced-ctc)))
|
||||
(set-recursive-contract-ctc! ctc forced-ctc)
|
||||
(set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
|
||||
(cddr old-name)))
|
||||
forced-ctc]
|
||||
[else current]))
|
||||
|
||||
(define ((recursive-contract-projection ctc) blame)
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (contract-projection r-ctc))
|
||||
(define blame-known (blame-add-context blame #f))
|
||||
(λ (val)
|
||||
((f blame-known) val)))
|
||||
|
||||
(define (recursive-contract-projection ctc)
|
||||
(cond
|
||||
[(recursive-contract-list-contract? ctc)
|
||||
(λ (blame)
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (contract-projection r-ctc))
|
||||
(define blame-known (blame-add-context blame #f))
|
||||
(λ (val)
|
||||
(unless (list? val)
|
||||
(raise-blame-error blame-known
|
||||
val
|
||||
'(expected: "list?" given: "~e")
|
||||
val))
|
||||
((f blame-known) val)))]
|
||||
[else
|
||||
(λ (blame)
|
||||
(define r-ctc (force-recursive-contract ctc))
|
||||
(define f (contract-projection r-ctc))
|
||||
(define blame-known (blame-add-context blame #f))
|
||||
(λ (val)
|
||||
((f blame-known) val)))]))
|
||||
|
||||
(define (recursive-contract-stronger this that)
|
||||
(and (recursive-contract? that)
|
||||
(procedure-closure-contents-eq? (recursive-contract-thunk this)
|
||||
|
|
@ -160,7 +183,7 @@
|
|||
(contract-first-order-passes? (force-recursive-contract ctc)
|
||||
val))
|
||||
|
||||
(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable]))
|
||||
(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?))
|
||||
|
||||
(struct flat-recursive-contract recursive-contract ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -169,7 +192,8 @@
|
|||
#:name recursive-contract-name
|
||||
#:first-order recursive-contract-first-order
|
||||
#:projection recursive-contract-projection
|
||||
#:stronger recursive-contract-stronger))
|
||||
#:stronger recursive-contract-stronger
|
||||
#:list-contract? recursive-contract-list-contract?))
|
||||
(struct chaperone-recursive-contract recursive-contract ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -177,7 +201,8 @@
|
|||
#:name recursive-contract-name
|
||||
#:first-order recursive-contract-first-order
|
||||
#:projection recursive-contract-projection
|
||||
#:stronger recursive-contract-stronger))
|
||||
#:stronger recursive-contract-stronger
|
||||
#:list-contract? recursive-contract-list-contract?))
|
||||
(struct impersonator-recursive-contract recursive-contract ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
|
|
@ -185,4 +210,5 @@
|
|||
#:name recursive-contract-name
|
||||
#:first-order recursive-contract-first-order
|
||||
#:projection recursive-contract-projection
|
||||
#:stronger recursive-contract-stronger))
|
||||
#:stronger recursive-contract-stronger
|
||||
#:list-contract? recursive-contract-list-contract?))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
"rand.rkt"
|
||||
"generate-base.rkt"
|
||||
racket/pretty
|
||||
racket/list
|
||||
(for-syntax racket/base
|
||||
"helpers.rkt"))
|
||||
|
||||
|
|
@ -20,7 +21,8 @@
|
|||
build-compound-type-name
|
||||
|
||||
contract-stronger?
|
||||
|
||||
list-contract?
|
||||
|
||||
contract-first-order
|
||||
contract-first-order-passes?
|
||||
|
||||
|
|
@ -123,6 +125,10 @@
|
|||
(coerce-contract 'contract-first-order-passes? c))
|
||||
v))
|
||||
|
||||
(define (list-contract? raw-c)
|
||||
(define c (coerce-contract/f raw-c))
|
||||
(and c (contract-struct-list-contract? c)))
|
||||
|
||||
;; contract-stronger? : contract contract -> boolean
|
||||
;; indicates if one contract is stronger (ie, likes fewer values) than another
|
||||
;; this is not a total order.
|
||||
|
|
@ -207,6 +213,7 @@
|
|||
x
|
||||
#f
|
||||
(memq x the-known-good-contracts))]
|
||||
[(null? x) (make-eq-contract x)]
|
||||
[(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
|
||||
[(or (bytes? x) (string? x)) (make-equal-contract x)]
|
||||
[(number? x) (make-=-contract x)]
|
||||
|
|
@ -356,7 +363,8 @@
|
|||
(eq? this-val (eq-contract-val that)))
|
||||
(and (predicate-contract? that)
|
||||
(predicate-contract-sane? that)
|
||||
((predicate-contract-pred that) this-val))))))
|
||||
((predicate-contract-pred that) this-val))))
|
||||
#:list-contract? (λ (c) (null? (eq-contract-val c)))))
|
||||
|
||||
(define-struct equal-contract (val)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -451,7 +459,9 @@
|
|||
(predicate-contract-name ctc)))
|
||||
(λ (fuel)
|
||||
(and built-in-generator
|
||||
(λ () (built-in-generator fuel))))])))))
|
||||
(λ () (built-in-generator fuel))))])))
|
||||
#:list-contract? (λ (ctc) (or (equal? (predicate-contract-pred ctc) null?)
|
||||
(equal? (predicate-contract-pred ctc) empty?)))))
|
||||
|
||||
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
|
||||
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
|
|
|
|||
|
|
@ -466,7 +466,8 @@
|
|||
#:projection (listof-*-ho-check (λ (p v) (for-each p v) v))
|
||||
#:val-first-projection (listof-*-val-first-flat-proj predicate? ctc)
|
||||
#:generate (generate ctc)
|
||||
#:exercise (exercise ctc))]
|
||||
#:exercise (exercise ctc)
|
||||
#:list-contract? #t)]
|
||||
[(chaperone-contract? ctc)
|
||||
(make-chaperone-contract
|
||||
#:name ctc-name
|
||||
|
|
@ -474,14 +475,16 @@
|
|||
#:projection (listof-*-ho-check (λ (p v) (map p v)))
|
||||
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
|
||||
#:generate (generate ctc)
|
||||
#:exercise (exercise ctc))]
|
||||
#:exercise (exercise ctc)
|
||||
#:list-contract? #t)]
|
||||
[else
|
||||
(make-contract
|
||||
#:name ctc-name
|
||||
#:first-order fo-check
|
||||
#:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
|
||||
#:projection (listof-*-ho-check (λ (p v) (map p v)))
|
||||
#:exercise (exercise ctc))])))
|
||||
#:exercise (exercise ctc)
|
||||
#:list-contract? #t)])))
|
||||
|
||||
(define (listof-*-val-first-flat-proj predicate? ctc)
|
||||
(define vf-proj (get/build-val-first-projection ctc))
|
||||
|
|
@ -593,6 +596,9 @@
|
|||
cdr-gen
|
||||
(λ () (cons (car-gen) (cdr-gen))))))
|
||||
|
||||
(define (cons/c-list-contract? c)
|
||||
(list-contract? (the-cons/c-tl-ctc c)))
|
||||
|
||||
(define-struct the-cons/c (hd-ctc tl-ctc))
|
||||
(define-struct (flat-cons/c the-cons/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -603,7 +609,8 @@
|
|||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
#:generate cons/c-generate))
|
||||
#:generate cons/c-generate
|
||||
#:list-contract? cons/c-list-contract?))
|
||||
(define-struct (chaperone-cons/c the-cons/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -614,7 +621,8 @@
|
|||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
#:generate cons/c-generate)))
|
||||
#:generate cons/c-generate
|
||||
#:list-contract? cons/c-list-contract?)))
|
||||
(define-struct (impersonator-cons/c the-cons/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
|
|
@ -624,7 +632,8 @@
|
|||
#:name cons/c-name
|
||||
#:first-order cons/c-first-order
|
||||
#:stronger cons/c-stronger?
|
||||
#:generate cons/c-generate))
|
||||
#:generate cons/c-generate
|
||||
#:list-contract? cons/c-list-contract?))
|
||||
|
||||
(define/subexpression-pos-prop (cons/c a b)
|
||||
(define ctc-car (coerce-contract 'cons/c a))
|
||||
|
|
@ -748,7 +757,8 @@
|
|||
(((contract-projection arg/c)
|
||||
(add-list-context blame i))
|
||||
v))
|
||||
x))))))
|
||||
x))))
|
||||
#:list-contract? (λ (c) #t)))
|
||||
|
||||
(define (list/c-chaperone/other-projection c)
|
||||
(define args (map contract-projection (generic-list/c-args c)))
|
||||
|
|
@ -830,7 +840,8 @@
|
|||
#:generate list/c-generate
|
||||
#:exercise list/c-exercise
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection)))
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection
|
||||
#:list-contract? (λ (c) #t))))
|
||||
|
||||
(struct higher-order-list/c generic-list/c ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -841,7 +852,8 @@
|
|||
#:generate list/c-generate
|
||||
#:exercise list/c-exercise
|
||||
#:projection list/c-chaperone/other-projection
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection))
|
||||
#:val-first-projection list/c-chaperone/other-val-first-projection
|
||||
#:list-contract? (λ (c) #t)))
|
||||
|
||||
(define/subexpression-pos-prop (syntax/c ctc-in)
|
||||
(let ([ctc (coerce-flat-contract 'syntax/c ctc-in)])
|
||||
|
|
|
|||
|
|
@ -168,6 +168,11 @@
|
|||
[else (option)])])))]
|
||||
[else #f]))
|
||||
|
||||
(define (single-or/c-list-contract? c)
|
||||
(and (list-contract? (single-or/c-ho-ctc c))
|
||||
(for/and ([c (in-list (single-or/c-flat-ctcs c))])
|
||||
(list-contract? c))))
|
||||
|
||||
(define-struct single-or/c (name pred flat-ctcs ho-ctc)
|
||||
#:property prop:orc-contract
|
||||
(λ (this) (cons (single-or/c-ho-ctc this)
|
||||
|
|
@ -186,7 +191,8 @@
|
|||
#:generate (λ (ctc) (or/c-generate ctc
|
||||
(cons (single-or/c-ho-ctc ctc)
|
||||
(single-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
|
||||
#:list-contract? single-or/c-list-contract?)))
|
||||
|
||||
(define-struct (impersonator-single-or/c single-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -200,7 +206,8 @@
|
|||
#:generate (λ (ctc) (or/c-generate ctc
|
||||
(cons (single-or/c-ho-ctc ctc)
|
||||
(single-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
|
||||
#:list-contract? single-or/c-list-contract?))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
|
|
@ -319,6 +326,12 @@
|
|||
(andmap contract-stronger? this-ctcs that-ctcs))))
|
||||
(generic-or/c-stronger? this that)))
|
||||
|
||||
(define (mult-or/c-list-contract? c)
|
||||
(and (for/and ([c (in-list (multi-or/c-flat-ctcs c))])
|
||||
(list-contract? c))
|
||||
(for/and ([c (in-list (multi-or/c-ho-ctcs c))])
|
||||
(list-contract? c))))
|
||||
|
||||
(define-struct multi-or/c (name flat-ctcs ho-ctcs)
|
||||
#:property prop:orc-contract
|
||||
(λ (this) (append (multi-or/c-ho-ctcs this)
|
||||
|
|
@ -337,7 +350,8 @@
|
|||
#:generate (λ (ctc) (or/c-generate ctc
|
||||
(append (multi-or/c-ho-ctcs ctc)
|
||||
(multi-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
|
||||
#:list-contract? mult-or/c-list-contract?)))
|
||||
|
||||
(define-struct (impersonator-multi-or/c multi-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -351,7 +365,8 @@
|
|||
#:generate (λ (ctc) (or/c-generate ctc
|
||||
(append (multi-or/c-ho-ctcs ctc)
|
||||
(multi-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
|
||||
#:list-contract? mult-or/c-list-contract?))
|
||||
|
||||
(define-struct flat-or/c (pred flat-ctcs)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -396,8 +411,11 @@
|
|||
|
||||
#:first-order
|
||||
(λ (ctc) (flat-or/c-pred ctc))
|
||||
#:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc)))))
|
||||
|
||||
#:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc)))
|
||||
#:list-contract?
|
||||
(λ (ctc)
|
||||
(for/and ([c (in-list (flat-or/c-flat-ctcs ctc))])
|
||||
(list-contract? c)))))
|
||||
|
||||
|
||||
(define/final-prop (symbols s1 . s2s)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
contract-struct-stronger?
|
||||
contract-struct-generate
|
||||
contract-struct-exercise
|
||||
contract-struct-list-contract?
|
||||
|
||||
prop:flat-contract
|
||||
flat-contract-struct?
|
||||
|
|
@ -55,7 +56,8 @@
|
|||
stronger
|
||||
generate
|
||||
exercise
|
||||
val-first-projection ]
|
||||
val-first-projection
|
||||
list-contract? ]
|
||||
#:omit-define-syntaxes)
|
||||
|
||||
(define (contract-property-guard prop info)
|
||||
|
|
@ -121,6 +123,10 @@
|
|||
(exercise c)
|
||||
(λ (fuel) (values void '()))))
|
||||
|
||||
(define (contract-struct-list-contract? c)
|
||||
(define prop (contract-struct-property c))
|
||||
((contract-property-list-contract? prop) c))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Chaperone Contract Property
|
||||
|
|
@ -215,7 +221,8 @@
|
|||
#:val-first-projection [get-val-first-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
||||
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
|
||||
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
|
||||
#:list-contract? [list-contract? (λ (c) #f)])
|
||||
|
||||
;; this code is here to help me find the combinators that
|
||||
;; are still using only #:projection and not #:val-first-projection
|
||||
|
|
@ -242,10 +249,16 @@
|
|||
get-name get-first-order)])]
|
||||
[stronger (or stronger weakest)])
|
||||
|
||||
(mk get-name get-first-order get-projection stronger generate exercise get-val-first-projection)))
|
||||
(mk get-name get-first-order
|
||||
get-projection stronger
|
||||
generate exercise
|
||||
get-val-first-projection
|
||||
list-contract?)))
|
||||
|
||||
(define build-contract-property
|
||||
(build-property make-contract-property 'anonymous-contract values))
|
||||
(procedure-rename
|
||||
(build-property make-contract-property 'anonymous-contract values)
|
||||
'build-contract-property))
|
||||
|
||||
;; Here we'll force the projection to always return the original value,
|
||||
;; instead of assuming that the provided projection does so appropriately.
|
||||
|
|
@ -257,9 +270,11 @@
|
|||
(λ (v) (p v) v))))))
|
||||
|
||||
(define build-flat-contract-property
|
||||
(build-property (compose make-flat-contract-property make-contract-property)
|
||||
'anonymous-flat-contract
|
||||
flat-projection-wrapper))
|
||||
(procedure-rename
|
||||
(build-property (compose make-flat-contract-property make-contract-property)
|
||||
'anonymous-flat-contract
|
||||
flat-projection-wrapper)
|
||||
'build-flat-contract-property))
|
||||
|
||||
(define (chaperone-projection-wrapper f)
|
||||
(λ (c)
|
||||
|
|
@ -279,9 +294,11 @@
|
|||
(c-proj (blame-add-unknown-context blame)))))
|
||||
|
||||
(define build-chaperone-contract-property
|
||||
(build-property (compose make-chaperone-contract-property make-contract-property)
|
||||
'anonymous-chaperone-contract
|
||||
chaperone-projection-wrapper))
|
||||
(procedure-rename
|
||||
(build-property (compose make-chaperone-contract-property make-contract-property)
|
||||
'anonymous-chaperone-contract
|
||||
chaperone-projection-wrapper)
|
||||
'build-chaperone-contract-property))
|
||||
|
||||
(define (get-any? c) any?)
|
||||
(define (any? x) #t)
|
||||
|
|
@ -309,7 +326,7 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct make-contract [ name first-order projection val-first-projection
|
||||
stronger generate exercise ]
|
||||
stronger generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
(λ (stct port display?)
|
||||
|
|
@ -324,10 +341,11 @@
|
|||
#:val-first-projection (lambda (c) (make-contract-val-first-projection c))
|
||||
#:stronger (lambda (a b) ((make-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-contract-generate c))
|
||||
#:exercise (lambda (c) (make-contract-exercise c))))
|
||||
#:exercise (lambda (c) (make-contract-exercise c))
|
||||
#:list-contract? (λ (c) (make-contract-list-contract? c))))
|
||||
|
||||
(define-struct make-chaperone-contract [ name first-order projection val-first-projection
|
||||
stronger generate exercise ]
|
||||
stronger generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
(λ (stct port display?)
|
||||
|
|
@ -342,10 +360,11 @@
|
|||
#:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c))
|
||||
#:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-chaperone-contract-generate c))
|
||||
#:exercise (lambda (c) (make-chaperone-contract-exercise c))))
|
||||
#:exercise (lambda (c) (make-chaperone-contract-exercise c))
|
||||
#:list-contract? (λ (c) (make-chaperone-contract-list-contract? c))))
|
||||
|
||||
(define-struct make-flat-contract [ name first-order projection val-first-projection
|
||||
stronger generate exercise ]
|
||||
stronger generate exercise list-contract? ]
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-write
|
||||
(λ (stct port display?)
|
||||
|
|
@ -360,7 +379,8 @@
|
|||
#:projection (lambda (c) (make-flat-contract-projection c))
|
||||
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
|
||||
#:generate (lambda (c) (make-flat-contract-generate c))
|
||||
#:exercise (lambda (c) (make-flat-contract-exercise c))))
|
||||
#:exercise (lambda (c) (make-flat-contract-exercise c))
|
||||
#:list-contract? (λ (c) (make-flat-contract-list-contract? c))))
|
||||
|
||||
(define ((build-contract mk default-name)
|
||||
#:name [name #f]
|
||||
|
|
@ -369,7 +389,8 @@
|
|||
#:val-first-projection [val-first-projection #f]
|
||||
#:stronger [stronger #f]
|
||||
#:generate [generate (λ (ctc) (λ (fuel) #f))]
|
||||
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
|
||||
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
|
||||
#:list-contract? [list-contract? (λ (ctc) #f)])
|
||||
|
||||
(let* ([name (or name default-name)]
|
||||
[first-order (or first-order any?)]
|
||||
|
|
@ -379,7 +400,11 @@
|
|||
(val-first-first-order-projection name first-order)))]
|
||||
[stronger (or stronger as-strong?)])
|
||||
|
||||
(mk name first-order projection val-first-projection stronger generate exercise)))
|
||||
(mk name first-order
|
||||
projection val-first-projection
|
||||
stronger
|
||||
generate exercise
|
||||
list-contract?)))
|
||||
|
||||
(define ((get-val-first-first-order-projection get-name get-first-order) c)
|
||||
(val-first-first-order-projection (get-name c) (get-first-order c)))
|
||||
|
|
@ -403,12 +428,19 @@
|
|||
(contract-struct-projection b)))
|
||||
|
||||
(define make-contract
|
||||
(build-contract make-make-contract 'anonymous-contract))
|
||||
(procedure-rename
|
||||
(build-contract make-make-contract 'anonymous-contract)
|
||||
'make-contract))
|
||||
|
||||
(define make-chaperone-contract
|
||||
(build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
|
||||
(procedure-rename
|
||||
(build-contract make-make-chaperone-contract 'anonymous-chaperone-contract)
|
||||
'make-chaperone-contract))
|
||||
|
||||
(define make-flat-contract (build-contract make-make-flat-contract 'anonymous-flat-contract))
|
||||
(define make-flat-contract
|
||||
(procedure-rename
|
||||
(build-contract make-make-flat-contract 'anonymous-flat-contract)
|
||||
'make-flat-contract))
|
||||
|
||||
;; property should be bound to a function that accepts the contract and
|
||||
;; returns a list of contracts that were the original arguments to the or/c
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user