make or/c and contract-stronger? collaborate
in order to make contract-stronger? work better when given the result of or/c
This commit is contained in:
Robby Findler
parent
6f259fbd42
commit
4de1583c68
|
|
@ -53,14 +53,25 @@
|
|||
(ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
|
||||
(ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
|
||||
(ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))
|
||||
(ctest #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
|
||||
(ctest #t contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
|
||||
(ctest #t contract-stronger?
|
||||
(or/c null? (-> integer? integer?))
|
||||
(or/c null? (-> integer? integer?)))
|
||||
(ctest #f contract-stronger?
|
||||
(or/c null? (-> boolean? boolean?))
|
||||
(or/c null? (-> integer? integer?)))
|
||||
|
||||
(ctest #f contract-stronger? (or/c number? #f) number?)
|
||||
(ctest #t contract-stronger? number? (or/c number? #f))
|
||||
(ctest #f contract-stronger? (or/c (-> number? number?) #f) (-> number? number?))
|
||||
(ctest #t contract-stronger? (-> number? number?) (or/c (-> number? number?) #f))
|
||||
(ctest #f contract-stronger? (or/c (-> number? number?) (-> number? number? number?) #f) #f)
|
||||
(ctest #t contract-stronger? #f (or/c (-> number? number?) (-> number? number? number?) #f))
|
||||
(ctest #t contract-stronger? (or/c real?) (or/c integer? real?))
|
||||
(ctest #t contract-stronger? (-> number?) (-> (or/c #f number?)))
|
||||
(ctest #t contract-stronger? (-> (or/c #f number?) any/c) (-> number? any/c))
|
||||
(ctest #f contract-stronger? (-> (or/c #f number?)) (-> number?))
|
||||
(ctest #f contract-stronger? (-> number? any/c) (-> (or/c #f number?) any/c))
|
||||
|
||||
(ctest #t contract-stronger? number? number?)
|
||||
(ctest #f contract-stronger? boolean? number?)
|
||||
|
||||
|
|
@ -102,7 +113,7 @@
|
|||
(ctest #f contract-stronger?
|
||||
(or/c (-> string?) (-> integer? integer?) integer? char?)
|
||||
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
|
||||
(ctest #f contract-stronger?
|
||||
(ctest #t contract-stronger?
|
||||
(or/c (-> string?) (-> integer? integer?) integer?)
|
||||
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
|
||||
(ctest #f contract-stronger?
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@
|
|||
"private/basic-opters.rkt" ;; required for effect to install the opters
|
||||
"private/opt.rkt"
|
||||
"private/out.rkt"
|
||||
"private/arrow-val-first.rkt")
|
||||
"private/arrow-val-first.rkt"
|
||||
"private/orc.rkt")
|
||||
|
||||
(provide
|
||||
(except-out (all-from-out "private/arrow.rkt")
|
||||
|
|
@ -48,6 +49,7 @@
|
|||
(except-out (all-from-out "private/misc.rkt")
|
||||
check-between/c
|
||||
check-unary-between/c)
|
||||
symbols or/c one-of/c
|
||||
provide/contract
|
||||
;(for-syntax make-provide/contract-transformer) ;; not documented!
|
||||
contract-out
|
||||
|
|
|
|||
|
|
@ -355,9 +355,9 @@
|
|||
(build-flat-contract-property
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(and (predicate-contract? that)
|
||||
(procedure-closure-contents-eq? (predicate-contract-pred this)
|
||||
(predicate-contract-pred that))))
|
||||
(and (predicate-contract? that)
|
||||
(procedure-closure-contents-eq? (predicate-contract-pred this)
|
||||
(predicate-contract-pred that))))
|
||||
#:name (λ (ctc) (predicate-contract-name ctc))
|
||||
#:first-order (λ (ctc) (predicate-contract-pred ctc))
|
||||
#:val-first-projection
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@
|
|||
|
||||
(provide flat-rec-contract
|
||||
flat-murec-contract
|
||||
or/c
|
||||
and/c
|
||||
not/c
|
||||
=/c >=/c <=/c </c >/c between/c
|
||||
|
|
@ -21,7 +20,6 @@
|
|||
string-len/c
|
||||
false/c
|
||||
printable/c
|
||||
symbols one-of/c
|
||||
listof non-empty-listof cons/c list/c
|
||||
promise/c
|
||||
syntax/c
|
||||
|
|
@ -57,7 +55,6 @@
|
|||
contract-name
|
||||
n->th
|
||||
|
||||
blame-add-or-context
|
||||
blame-add-car-context
|
||||
blame-add-cdr-context
|
||||
raise-not-cons-blame-error)
|
||||
|
|
@ -115,307 +112,6 @@
|
|||
|
||||
(define (flat-murec-contract/init x) (error 'flat-murec-contract "applied too soon"))
|
||||
|
||||
(define/subexpression-pos-prop or/c
|
||||
(case-lambda
|
||||
[() (make-none/c '(or/c))]
|
||||
[raw-args
|
||||
(define args (coerce-contracts 'or/c raw-args))
|
||||
(define-values (ho-contracts flat-contracts)
|
||||
(let loop ([ho-contracts '()]
|
||||
[flat-contracts '()]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ho-contracts (reverse flat-contracts))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(flat-contract? arg)
|
||||
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
|
||||
[else
|
||||
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
|
||||
(define pred
|
||||
(cond
|
||||
[(null? flat-contracts) not]
|
||||
[else
|
||||
(let loop ([fst (car flat-contracts)]
|
||||
[rst (cdr flat-contracts)])
|
||||
(let ([fst-pred (flat-contract-predicate fst)])
|
||||
(cond
|
||||
[(null? rst) fst-pred]
|
||||
[else
|
||||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (x) (or (fst-pred x) (r x))))])))]))
|
||||
|
||||
(cond
|
||||
[(null? ho-contracts)
|
||||
(make-flat-or/c pred flat-contracts)]
|
||||
[(null? (cdr ho-contracts))
|
||||
(define name (apply build-compound-type-name 'or/c args))
|
||||
(if (chaperone-contract? (car ho-contracts))
|
||||
(make-chaperone-single-or/c name pred flat-contracts (car ho-contracts))
|
||||
(make-impersonator-single-or/c name pred flat-contracts (car ho-contracts)))]
|
||||
[else
|
||||
(define name (apply build-compound-type-name 'or/c args))
|
||||
(if (andmap chaperone-contract? ho-contracts)
|
||||
(make-chaperone-multi-or/c name flat-contracts ho-contracts)
|
||||
(make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))
|
||||
|
||||
(define (single-or/c-projection ctc)
|
||||
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
|
||||
[pred (single-or/c-pred ctc)])
|
||||
(λ (blame)
|
||||
(define partial-contract
|
||||
(c-proc (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)])))))
|
||||
|
||||
(define (single-or/c-val-first-projection ctc)
|
||||
(define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc)))
|
||||
(define pred (single-or/c-pred ctc))
|
||||
(λ (blame)
|
||||
(define p-app (c-proj (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(if (pred val)
|
||||
(λ (neg-party) val)
|
||||
(p-app val)))))
|
||||
|
||||
(define (blame-add-or-context blame)
|
||||
(blame-add-context blame "a disjunct of"))
|
||||
|
||||
(define (single-or/c-first-order ctc)
|
||||
(let ([pred (single-or/c-pred ctc)]
|
||||
[ho (contract-first-order (single-or/c-ho-ctc ctc))])
|
||||
(λ (x) (or (ho x) (pred x)))))
|
||||
|
||||
(define (single-or/c-stronger? this that)
|
||||
(and (single-or/c? that)
|
||||
(contract-stronger? (single-or/c-ho-ctc this)
|
||||
(single-or/c-ho-ctc that))
|
||||
(let ([this-ctcs (single-or/c-flat-ctcs this)]
|
||||
[that-ctcs (single-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs)))))
|
||||
|
||||
(define-struct single-or/c (name pred flat-ctcs ho-ctc))
|
||||
|
||||
(define-struct (chaperone-single-or/c single-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:val-first-projection single-or/c-val-first-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?)))
|
||||
|
||||
(define-struct (impersonator-single-or/c single-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:val-first-projection single-or/c-val-first-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
|
||||
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
|
||||
(λ (blame)
|
||||
(define disj-blame (blame-add-context blame "a disjunct of"))
|
||||
(define partial-contracts
|
||||
(for/list ([c-proc (in-list c-procs)])
|
||||
(c-proc disj-blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-blame-error blame val
|
||||
'("none of the branches of the or/c matched" given: "~e")
|
||||
val))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
'("two of the clauses in the or/c might both match: ~s and ~s"
|
||||
given:
|
||||
"~e")
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))])))))
|
||||
|
||||
(define (multi-or/c-val-first-proj ctc)
|
||||
(define ho-contracts (multi-or/c-ho-ctcs ctc))
|
||||
(define c-projs (map get/build-val-first-projection ho-contracts))
|
||||
(define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
|
||||
(define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
|
||||
(λ (blame)
|
||||
(define blame-w-context (blame-add-or-context blame))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(for/or ([pred (in-list predicates)])
|
||||
(pred val))
|
||||
(λ (neg-party) val)]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[c-projs c-projs]
|
||||
[contracts ho-contracts]
|
||||
[candidate-c-proj #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(cond
|
||||
[candidate-c-proj
|
||||
((candidate-c-proj blame-w-context) val)]
|
||||
[else
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame val #:missing-party neg-party
|
||||
'("none of the branches of the or/c matched" given: "~e")
|
||||
val))])]
|
||||
[((car checks) val)
|
||||
(if candidate-c-proj
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame val #:missing-party neg-party
|
||||
'("two of the clauses in the or/c might both match: ~s and ~s"
|
||||
given:
|
||||
"~e")
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val))
|
||||
(loop (cdr checks)
|
||||
(cdr c-projs)
|
||||
(cdr contracts)
|
||||
(car c-projs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr c-projs)
|
||||
(cdr contracts)
|
||||
candidate-c-proj
|
||||
candidate-contract)]))]))))
|
||||
|
||||
(define (multi-or/c-first-order ctc)
|
||||
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
|
||||
[hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
|
||||
(λ (x)
|
||||
(or (ormap (λ (f) (f x)) hos)
|
||||
(ormap (λ (f) (f x)) flats)))))
|
||||
|
||||
(define (multi-or/c-stronger? this that)
|
||||
(and (multi-or/c? that)
|
||||
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
|
||||
[that-ctcs (multi-or/c-ho-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger? this-ctcs that-ctcs)))
|
||||
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
|
||||
[that-ctcs (multi-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger? this-ctcs that-ctcs)))))
|
||||
|
||||
(define-struct multi-or/c (name flat-ctcs ho-ctcs))
|
||||
|
||||
(define-struct (chaperone-multi-or/c multi-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:val-first-projection multi-or/c-val-first-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?)))
|
||||
|
||||
(define-struct (impersonator-multi-or/c multi-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:val-first-projection multi-or/c-val-first-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?))
|
||||
|
||||
(define-struct flat-or/c (pred flat-ctcs)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(flat-or/c-flat-ctcs ctc)))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(and (flat-or/c? that)
|
||||
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
|
||||
[that-ctcs (flat-or/c-flat-ctcs that)])
|
||||
(cond
|
||||
[(and (<= (length this-ctcs) (length that-ctcs))
|
||||
(for/and ([this-ctc (in-list this-ctcs)]
|
||||
[that-ctc (in-list that-ctcs)])
|
||||
(contract-stronger? this-ctc that-ctc)))
|
||||
#t]
|
||||
[(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
|
||||
(andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
|
||||
(define ht (make-hash))
|
||||
(for ([x (in-list that-ctcs)])
|
||||
(hash-set! ht
|
||||
(if (equal-contract? x)
|
||||
(equal-contract-val x)
|
||||
(eq-contract-val x))
|
||||
#t))
|
||||
(for/and ([x (in-list this-ctcs)])
|
||||
(hash-ref ht
|
||||
(if (equal-contract? x)
|
||||
(equal-contract-val x)
|
||||
(eq-contract-val x))
|
||||
#f))]
|
||||
[else #f]))))
|
||||
|
||||
|
||||
#:first-order
|
||||
(λ (ctc) (flat-or/c-pred ctc))
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
(λ (fuel)
|
||||
(define choices
|
||||
(filter
|
||||
values
|
||||
(for/list ([ctc (in-list (flat-or/c-flat-ctcs ctc))])
|
||||
(generate/choose ctc fuel))))
|
||||
(cond
|
||||
[(null? choices) #f]
|
||||
[else
|
||||
(lambda ()
|
||||
((oneof choices)))])))))
|
||||
|
||||
|
||||
(define (and-name ctc)
|
||||
(apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
|
||||
|
|
@ -554,39 +250,6 @@
|
|||
(and (string? x)
|
||||
((string-length x) . < . n)))))
|
||||
|
||||
(define/final-prop (symbols s1 . s2s)
|
||||
(define ss (cons s1 s2s))
|
||||
(for ([arg (in-list ss)]
|
||||
[i (in-naturals)])
|
||||
(unless (symbol? arg)
|
||||
(raise-argument-error 'symbols
|
||||
"symbol?"
|
||||
i
|
||||
ss)))
|
||||
(apply or/c ss))
|
||||
|
||||
(define atomic-value?
|
||||
(λ (x)
|
||||
(or (char? x) (symbol? x) (boolean? x)
|
||||
(null? x) (keyword? x) (number? x)
|
||||
(void? x))))
|
||||
|
||||
(define/final-prop (one-of/c . elems)
|
||||
(for ([arg (in-list elems)]
|
||||
[i (in-naturals)])
|
||||
(unless (atomic-value? arg)
|
||||
(raise-argument-error 'one-of/c
|
||||
"char, symbol, boolean, null, keyword, number, or void"
|
||||
i
|
||||
elems)))
|
||||
(define or/c-args
|
||||
(map (λ (x)
|
||||
(cond
|
||||
[(void? x) void?]
|
||||
[else x]))
|
||||
elems))
|
||||
(apply or/c or/c-args))
|
||||
|
||||
(define-struct between/c (low high)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:omit-define-syntaxes
|
||||
|
|
|
|||
409
racket/collects/racket/contract/private/orc.rkt
Normal file
409
racket/collects/racket/contract/private/orc.rkt
Normal file
|
|
@ -0,0 +1,409 @@
|
|||
#lang racket/base
|
||||
(require "prop.rkt"
|
||||
"blame.rkt"
|
||||
"guts.rkt"
|
||||
"rand.rkt"
|
||||
"generate.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(provide symbols or/c one-of/c
|
||||
blame-add-or-context)
|
||||
|
||||
(define/subexpression-pos-prop or/c
|
||||
(case-lambda
|
||||
[() (make-none/c '(or/c))]
|
||||
[raw-args
|
||||
(define args (coerce-contracts 'or/c raw-args))
|
||||
(define-values (ho-contracts flat-contracts)
|
||||
(let loop ([ho-contracts '()]
|
||||
[flat-contracts '()]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ho-contracts (reverse flat-contracts))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(flat-contract? arg)
|
||||
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
|
||||
[else
|
||||
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
|
||||
(define pred
|
||||
(cond
|
||||
[(null? flat-contracts) not]
|
||||
[else
|
||||
(let loop ([fst (car flat-contracts)]
|
||||
[rst (cdr flat-contracts)])
|
||||
(let ([fst-pred (flat-contract-predicate fst)])
|
||||
(cond
|
||||
[(null? rst) fst-pred]
|
||||
[else
|
||||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (x) (or (fst-pred x) (r x))))])))]))
|
||||
|
||||
(cond
|
||||
[(null? ho-contracts)
|
||||
(make-flat-or/c pred flat-contracts)]
|
||||
[(null? (cdr ho-contracts))
|
||||
(define name (apply build-compound-type-name 'or/c args))
|
||||
(if (chaperone-contract? (car ho-contracts))
|
||||
(make-chaperone-single-or/c name pred flat-contracts (car ho-contracts))
|
||||
(make-impersonator-single-or/c name pred flat-contracts (car ho-contracts)))]
|
||||
[else
|
||||
(define name (apply build-compound-type-name 'or/c args))
|
||||
(if (andmap chaperone-contract? ho-contracts)
|
||||
(make-chaperone-multi-or/c name flat-contracts ho-contracts)
|
||||
(make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))
|
||||
|
||||
(define (single-or/c-projection ctc)
|
||||
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
|
||||
[pred (single-or/c-pred ctc)])
|
||||
(λ (blame)
|
||||
(define partial-contract
|
||||
(c-proc (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)])))))
|
||||
|
||||
(define (single-or/c-val-first-projection ctc)
|
||||
(define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc)))
|
||||
(define pred (single-or/c-pred ctc))
|
||||
(λ (blame)
|
||||
(define p-app (c-proj (blame-add-or-context blame)))
|
||||
(λ (val)
|
||||
(if (pred val)
|
||||
(λ (neg-party) val)
|
||||
(p-app val)))))
|
||||
|
||||
(define (blame-add-or-context blame)
|
||||
(blame-add-context blame "a disjunct of"))
|
||||
|
||||
(define (single-or/c-first-order ctc)
|
||||
(let ([pred (single-or/c-pred ctc)]
|
||||
[ho (contract-first-order (single-or/c-ho-ctc ctc))])
|
||||
(λ (x) (or (ho x) (pred x)))))
|
||||
|
||||
(define (single-or/c-stronger? this that)
|
||||
(or (and (single-or/c? that)
|
||||
(contract-stronger? (single-or/c-ho-ctc this)
|
||||
(single-or/c-ho-ctc that))
|
||||
(let ([this-ctcs (single-or/c-flat-ctcs this)]
|
||||
[that-ctcs (single-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))
|
||||
(generic-or/c-stronger? this that)))
|
||||
|
||||
(define (generic-or/c-stronger? this that)
|
||||
(define this-sub-ctcs (or/c-sub-contracts this))
|
||||
(define that-sub-ctcs (or/c-sub-contracts that))
|
||||
(and this-sub-ctcs
|
||||
that-sub-ctcs
|
||||
(for/and ([this-sub-ctc (in-list this-sub-ctcs)])
|
||||
(for/or ([that-sub-ctc (in-list that-sub-ctcs)])
|
||||
(contract-stronger? this-sub-ctc that-sub-ctc)))))
|
||||
|
||||
(define (or/c-sub-contracts ctc)
|
||||
(cond
|
||||
[(single-or/c? ctc)
|
||||
(cons (single-or/c-ho-ctc ctc)
|
||||
(single-or/c-flat-ctcs ctc))]
|
||||
[(multi-or/c? ctc)
|
||||
(append (multi-or/c-flat-ctcs ctc)
|
||||
(multi-or/c-ho-ctcs ctc))]
|
||||
[(flat-or/c? ctc)
|
||||
(flat-or/c-flat-ctcs ctc)]
|
||||
[else #f]))
|
||||
|
||||
(define (or/c-exercise ho-contracts)
|
||||
(λ (fuel)
|
||||
(define env (generate-env))
|
||||
(values (λ (val)
|
||||
(let loop ([ho-contracts ho-contracts])
|
||||
(unless (null? ho-contracts)
|
||||
(define ctc (car ho-contracts))
|
||||
(cond
|
||||
[((contract-first-order ctc) val)
|
||||
(define-values (exercise ctcs) ((contract-struct-exercise ctc) fuel))
|
||||
(exercise val)
|
||||
(env-stash env ctc val)]
|
||||
[else
|
||||
(loop (cdr ho-contracts))]))))
|
||||
'())))
|
||||
|
||||
(define (or/c-generate ctcs)
|
||||
(λ (fuel)
|
||||
(define choices
|
||||
(filter
|
||||
values
|
||||
(for/list ([ctc (in-list ctcs)])
|
||||
(generate/choose ctc fuel))))
|
||||
(cond
|
||||
[(null? choices) #f]
|
||||
[else
|
||||
(lambda ()
|
||||
((oneof choices)))])))
|
||||
|
||||
(define-struct single-or/c (name pred flat-ctcs ho-ctc)
|
||||
#:property prop:orc-contract
|
||||
(λ (this) (cons (single-or/c-ho-ctc this)
|
||||
(single-or/c-flat-ctcs this))))
|
||||
|
||||
(define-struct (chaperone-single-or/c single-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:val-first-projection single-or/c-val-first-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?
|
||||
#:generate (λ (ctc) (or/c-generate (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)))))))
|
||||
|
||||
(define-struct (impersonator-single-or/c single-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection single-or/c-projection
|
||||
#:val-first-projection single-or/c-val-first-projection
|
||||
#:name single-or/c-name
|
||||
#:first-order single-or/c-first-order
|
||||
#:stronger single-or/c-stronger?
|
||||
#:generate (λ (ctc) (or/c-generate (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))))))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
|
||||
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
|
||||
(λ (blame)
|
||||
(define disj-blame (blame-add-context blame "a disjunct of"))
|
||||
(define partial-contracts
|
||||
(for/list ([c-proc (in-list c-procs)])
|
||||
(c-proc disj-blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-blame-error blame val
|
||||
'("none of the branches of the or/c matched" given: "~e")
|
||||
val))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
'("two of the clauses in the or/c might both match: ~s and ~s"
|
||||
given:
|
||||
"~e")
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))])))))
|
||||
|
||||
(define (multi-or/c-val-first-proj ctc)
|
||||
(define ho-contracts (multi-or/c-ho-ctcs ctc))
|
||||
(define c-projs (map get/build-val-first-projection ho-contracts))
|
||||
(define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
|
||||
(define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
|
||||
(λ (blame)
|
||||
(define blame-w-context (blame-add-or-context blame))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(for/or ([pred (in-list predicates)])
|
||||
(pred val))
|
||||
(λ (neg-party) val)]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[c-projs c-projs]
|
||||
[contracts ho-contracts]
|
||||
[candidate-c-proj #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(cond
|
||||
[candidate-c-proj
|
||||
((candidate-c-proj blame-w-context) val)]
|
||||
[else
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame val #:missing-party neg-party
|
||||
'("none of the branches of the or/c matched" given: "~e")
|
||||
val))])]
|
||||
[((car checks) val)
|
||||
(if candidate-c-proj
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame val #:missing-party neg-party
|
||||
'("two of the clauses in the or/c might both match: ~s and ~s"
|
||||
given:
|
||||
"~e")
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val))
|
||||
(loop (cdr checks)
|
||||
(cdr c-projs)
|
||||
(cdr contracts)
|
||||
(car c-projs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr c-projs)
|
||||
(cdr contracts)
|
||||
candidate-c-proj
|
||||
candidate-contract)]))]))))
|
||||
|
||||
(define (multi-or/c-first-order ctc)
|
||||
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
|
||||
[hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
|
||||
(λ (x)
|
||||
(or (ormap (λ (f) (f x)) hos)
|
||||
(ormap (λ (f) (f x)) flats)))))
|
||||
|
||||
(define (multi-or/c-stronger? this that)
|
||||
(or (and (multi-or/c? that)
|
||||
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
|
||||
[that-ctcs (multi-or/c-ho-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger? this-ctcs that-ctcs)))
|
||||
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
|
||||
[that-ctcs (multi-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger? this-ctcs that-ctcs))))
|
||||
(generic-or/c-stronger? this that)))
|
||||
|
||||
(define-struct multi-or/c (name flat-ctcs ho-ctcs)
|
||||
#:property prop:orc-contract
|
||||
(λ (this) (append (multi-or/c-ho-ctcs this)
|
||||
(multi-or/c-flat-ctcs this))))
|
||||
|
||||
(define-struct (chaperone-multi-or/c multi-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
(build-chaperone-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:val-first-projection multi-or/c-val-first-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?
|
||||
#:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
|
||||
(multi-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))))
|
||||
|
||||
(define-struct (impersonator-multi-or/c multi-or/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection multi-or/c-proj
|
||||
#:val-first-projection multi-or/c-val-first-proj
|
||||
#:name multi-or/c-name
|
||||
#:first-order multi-or/c-first-order
|
||||
#:stronger multi-or/c-stronger?
|
||||
#:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
|
||||
(multi-or/c-flat-ctcs ctc))))
|
||||
#:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))
|
||||
|
||||
(define-struct flat-or/c (pred flat-ctcs)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:orc-contract
|
||||
(λ (this) (flat-or/c-flat-ctcs this))
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(flat-or/c-flat-ctcs ctc)))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(or (and (flat-or/c? that)
|
||||
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
|
||||
[that-ctcs (flat-or/c-flat-ctcs that)])
|
||||
(cond
|
||||
[(and (<= (length this-ctcs) (length that-ctcs))
|
||||
(for/and ([this-ctc (in-list this-ctcs)]
|
||||
[that-ctc (in-list that-ctcs)])
|
||||
(contract-stronger? this-ctc that-ctc)))
|
||||
#t]
|
||||
[(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
|
||||
(andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
|
||||
(define ht (make-hash))
|
||||
(for ([x (in-list that-ctcs)])
|
||||
(hash-set! ht
|
||||
(if (equal-contract? x)
|
||||
(equal-contract-val x)
|
||||
(eq-contract-val x))
|
||||
#t))
|
||||
(for/and ([x (in-list this-ctcs)])
|
||||
(hash-ref ht
|
||||
(if (equal-contract? x)
|
||||
(equal-contract-val x)
|
||||
(eq-contract-val x))
|
||||
#f))]
|
||||
[else #f])))
|
||||
(generic-or/c-stronger? this that)))
|
||||
|
||||
|
||||
#:first-order
|
||||
(λ (ctc) (flat-or/c-pred ctc))
|
||||
#:generate (λ (ctc) (or/c-generate (flat-or/c-flat-ctcs ctc)))))
|
||||
|
||||
|
||||
|
||||
(define/final-prop (symbols s1 . s2s)
|
||||
(define ss (cons s1 s2s))
|
||||
(for ([arg (in-list ss)]
|
||||
[i (in-naturals)])
|
||||
(unless (symbol? arg)
|
||||
(raise-argument-error 'symbols
|
||||
"symbol?"
|
||||
i
|
||||
ss)))
|
||||
(apply or/c ss))
|
||||
|
||||
|
||||
|
||||
(define/final-prop (one-of/c . elems)
|
||||
(for ([arg (in-list elems)]
|
||||
[i (in-naturals)])
|
||||
(unless (atomic-value? arg)
|
||||
(raise-argument-error 'one-of/c
|
||||
"char, symbol, boolean, null, keyword, number, or void"
|
||||
i
|
||||
elems)))
|
||||
(define or/c-args
|
||||
(map (λ (x)
|
||||
(cond
|
||||
[(void? x) void?]
|
||||
[else x]))
|
||||
elems))
|
||||
(apply or/c or/c-args))
|
||||
|
||||
(define atomic-value?
|
||||
(λ (x)
|
||||
(or (char? x) (symbol? x) (boolean? x)
|
||||
(null? x) (keyword? x) (number? x)
|
||||
(void? x))))
|
||||
|
|
@ -36,8 +36,12 @@
|
|||
skip-projection-wrapper?
|
||||
|
||||
prop:opt-chaperone-contract
|
||||
prop:opt-chaperone-contract?
|
||||
prop:opt-chaperone-contract-get-test)
|
||||
prop:opt-chaperone-contract?
|
||||
prop:opt-chaperone-contract-get-test
|
||||
|
||||
prop:orc-contract
|
||||
prop:orc-contract?
|
||||
prop:orc-contract-get-subcontracts)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
@ -92,9 +96,16 @@
|
|||
(get-projection c)))
|
||||
|
||||
(define (contract-struct-stronger? a b)
|
||||
(let* ([prop (contract-struct-property a)]
|
||||
[stronger (contract-property-stronger prop)])
|
||||
(stronger a b)))
|
||||
(define prop (contract-struct-property a))
|
||||
(define stronger? (contract-property-stronger prop))
|
||||
(let loop ([b b])
|
||||
(cond
|
||||
[(stronger? a b) #t]
|
||||
[(prop:orc-contract? b)
|
||||
(define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
|
||||
(for/or ([sub-contract (in-list sub-contracts)])
|
||||
(loop sub-contract))]
|
||||
[else #f])))
|
||||
|
||||
(define (contract-struct-generate c)
|
||||
(define prop (contract-struct-property c))
|
||||
|
|
@ -398,3 +409,8 @@
|
|||
(build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
|
||||
|
||||
(define make-flat-contract (build-contract make-make-flat-contract 'anonymous-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
|
||||
(define-values (prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts)
|
||||
(make-struct-type-property 'prop:orc-contract))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user