got rid of define-struct/prop since scheme/base has a define-struct that does all that (and more) now
svn: r11727
This commit is contained in:
Robby Findler
parent
c6c876a821
commit
06a4d0df4a
|
|
@ -62,62 +62,66 @@
|
|||
;; func : the wrapper function maker. It accepts a procedure for
|
||||
;; checking the first-order properties and the contracts
|
||||
;; and it produces a wrapper-making function.
|
||||
(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
((proj-prop (λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds)))))))
|
||||
(name-prop (λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x)))))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))))
|
||||
(define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds))))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc)))
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x))))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))
|
||||
|
||||
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -86,18 +86,6 @@ v4 todo:
|
|||
;
|
||||
|
||||
|
||||
(define (build--> name
|
||||
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
|
||||
mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
|
||||
rngs/c-or-p
|
||||
rng-any? func)
|
||||
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
|
||||
(make-->
|
||||
(map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
|
||||
(map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
|
||||
(map cc rngs/c-or-p) rng-any?
|
||||
func)))
|
||||
|
||||
;; doms : (listof contract)
|
||||
;; optional-doms/c : (listof contract)
|
||||
;; dom-rest : (or/c false/c contract)
|
||||
|
|
@ -110,78 +98,95 @@ v4 todo:
|
|||
;; func : the wrapper function maker. It accepts a procedure for
|
||||
;; checking the first-order properties and the contracts
|
||||
;; and it produces a wrapper-making function.
|
||||
(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
|
||||
((proj-prop (λ (ctc)
|
||||
(let* ([doms-proj (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest/c ctc)
|
||||
(append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
|
||||
(->-doms/c ctc)))]
|
||||
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
|
||||
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
|
||||
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
|
||||
[optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
|
||||
[mandatory-keywords (->-mandatory-kwds ctc)]
|
||||
[optional-keywords (->-optional-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms/c ctc))]
|
||||
[optionals-length (length (->-optional-doms/c ctc))]
|
||||
[has-rest? (and (->-dom-rest/c ctc) #t)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-proj)]
|
||||
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-optional-proj)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs-proj)]
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
mandatory-kwds-proj)]
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
optional-kwds-proj)])
|
||||
(apply func
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges)))))))
|
||||
(name-prop (λ (ctc) (single-arrow-name-maker
|
||||
(->-doms/c ctc)
|
||||
(->-optional-doms/c ctc)
|
||||
(->-dom-rest/c ctc)
|
||||
(->-mandatory-kwds/c ctc)
|
||||
(->-mandatory-kwds ctc)
|
||||
(->-optional-kwds/c ctc)
|
||||
(->-optional-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs/c ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(λ (x)
|
||||
(let ([l (length (->-doms/c ctc))])
|
||||
(and (procedure? x)
|
||||
(if (->-dom-rest/c ctc)
|
||||
(procedure-accepts-and-more? x l)
|
||||
(procedure-arity-includes? x l))
|
||||
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
|
||||
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
|
||||
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
|
||||
(->-mandatory-kwds ctc))))
|
||||
#t)))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms/c that)) (length (->-doms/c this)))
|
||||
(andmap contract-stronger? (->-doms/c that) (->-doms/c this))
|
||||
|
||||
(equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
|
||||
(andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
|
||||
|
||||
(equal? (->-optional-kwds this) (->-optional-kwds that))
|
||||
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
|
||||
|
||||
(= (length (->-rngs/c that)) (length (->-rngs/c this)))
|
||||
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))))
|
||||
(define-struct -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([doms-proj (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest/c ctc)
|
||||
(append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
|
||||
(->-doms/c ctc)))]
|
||||
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
|
||||
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
|
||||
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
|
||||
[optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
|
||||
[mandatory-keywords (->-mandatory-kwds ctc)]
|
||||
[optional-keywords (->-optional-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms/c ctc))]
|
||||
[optionals-length (length (->-optional-doms/c ctc))]
|
||||
[has-rest? (and (->-dom-rest/c ctc) #t)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-proj)]
|
||||
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-optional-proj)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs-proj)]
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
mandatory-kwds-proj)]
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
optional-kwds-proj)])
|
||||
(apply func
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (single-arrow-name-maker
|
||||
(->-doms/c ctc)
|
||||
(->-optional-doms/c ctc)
|
||||
(->-dom-rest/c ctc)
|
||||
(->-mandatory-kwds/c ctc)
|
||||
(->-mandatory-kwds ctc)
|
||||
(->-optional-kwds/c ctc)
|
||||
(->-optional-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs/c ctc)))
|
||||
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(λ (x)
|
||||
(let ([l (length (->-doms/c ctc))])
|
||||
(and (procedure? x)
|
||||
(if (->-dom-rest/c ctc)
|
||||
(procedure-accepts-and-more? x l)
|
||||
(procedure-arity-includes? x l))
|
||||
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
|
||||
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
|
||||
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
|
||||
(->-mandatory-kwds ctc))))
|
||||
#t))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms/c that)) (length (->-doms/c this)))
|
||||
(andmap contract-stronger? (->-doms/c that) (->-doms/c this))
|
||||
|
||||
(equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
|
||||
(andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
|
||||
|
||||
(equal? (->-optional-kwds this) (->-optional-kwds that))
|
||||
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
|
||||
|
||||
(= (length (->-rngs/c that)) (length (->-rngs/c this)))
|
||||
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))
|
||||
|
||||
(define (build--> name
|
||||
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
|
||||
mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
|
||||
rngs/c-or-p
|
||||
rng-any? func)
|
||||
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
|
||||
(make-->
|
||||
(map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
|
||||
(map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
|
||||
(map cc rngs/c-or-p) rng-any?
|
||||
func)))
|
||||
|
||||
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs)
|
||||
(cond
|
||||
|
|
@ -1014,67 +1019,72 @@ v4 todo:
|
|||
;; the `box' in the range only serves to differentiate between range contracts that depend on
|
||||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
name-wrapper) ;; (-> proc proc)
|
||||
((proj-prop ->d-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let* ([counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
(λ ()
|
||||
(cond
|
||||
[(pair? ids)
|
||||
(begin0 (car ids)
|
||||
(set! ids (cdr ids)))]
|
||||
[(null? ids)
|
||||
(begin0
|
||||
(string->symbol (format "~a0" counting-id))
|
||||
(set! ids 1))]
|
||||
[else
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" counting-id ids))
|
||||
(set! ids (+ ids 1)))]))])
|
||||
`(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
|
||||
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
|
||||
,@(if (->d-rest-ctc ctc)
|
||||
(list '#:rest (next-id) '...)
|
||||
'())
|
||||
,@(if (->d-pre-cond ctc)
|
||||
(list '#:pre-cond '...)
|
||||
(list))
|
||||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
|
||||
,@(if (->d-post-cond ctc)
|
||||
(list '#:post-cond '...)
|
||||
(list))))))
|
||||
(first-order-prop (λ (ctc) (λ (x) #f)))
|
||||
(stronger-prop (λ (this that) (eq? this that)))))
|
||||
(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
name-wrapper) ;; (-> proc proc)
|
||||
|
||||
#:omit-define-syntaxes
|
||||
|
||||
#:property proj-prop ->d-proj
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(let* ([counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
(λ ()
|
||||
(cond
|
||||
[(pair? ids)
|
||||
(begin0 (car ids)
|
||||
(set! ids (cdr ids)))]
|
||||
[(null? ids)
|
||||
(begin0
|
||||
(string->symbol (format "~a0" counting-id))
|
||||
(set! ids 1))]
|
||||
[else
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" counting-id ids))
|
||||
(set! ids (+ ids 1)))]))])
|
||||
`(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
|
||||
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
|
||||
,@(if (->d-rest-ctc ctc)
|
||||
(list '#:rest (next-id) '...)
|
||||
'())
|
||||
,@(if (->d-pre-cond ctc)
|
||||
(list '#:pre-cond '...)
|
||||
(list))
|
||||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
|
||||
,@(if (->d-post-cond ctc)
|
||||
(list '#:post-cond '...)
|
||||
(list)))))
|
||||
|
||||
#:property first-order-prop (λ (ctc) (λ (x) #f))
|
||||
#:property stronger-prop (λ (this that) (eq? this that)))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -1180,60 +1190,62 @@ v4 todo:
|
|||
;; rng-ctcs : (listof (listof contract))
|
||||
;; specs : (listof (list boolean exact-positive-integer)) ;; indicates the required arities of the input functions
|
||||
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
|
||||
(define-struct/prop case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
|
||||
((proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([to-proj (λ (c) ((proj-get c) c))]
|
||||
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
|
||||
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
|
||||
(and rngs (map to-proj (get-case->-rng-ctcs ctc))))]
|
||||
[rst-ctcs (case->-rst-ctcs ctc)]
|
||||
[specs (case->-specs ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs)
|
||||
(map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))]
|
||||
[chk
|
||||
(λ (val mtd?)
|
||||
(cond
|
||||
[(null? specs)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected a procedure"))]
|
||||
[else
|
||||
(for-each
|
||||
(λ (dom-length has-rest?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str)
|
||||
(check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str)))
|
||||
specs rst-ctcs)]))])
|
||||
(apply (case->-wrapper ctc)
|
||||
chk
|
||||
projs))))))
|
||||
(name-prop (λ (ctc) (apply
|
||||
build-compound-type-name
|
||||
'case->
|
||||
(map (λ (dom rst range)
|
||||
(apply
|
||||
build-compound-type-name
|
||||
'->
|
||||
(append dom
|
||||
(if rst
|
||||
(list '#:rest rst)
|
||||
'())
|
||||
(list
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(and (pair? range) (null? (cdr range)))
|
||||
(car range)]
|
||||
[else (apply build-compound-type-name 'values range)])))))
|
||||
(case->-dom-ctcs ctc)
|
||||
(case->-rst-ctcs ctc)
|
||||
(case->-rng-ctcs ctc)))))
|
||||
(first-order-prop (λ (ctc) (λ (val) #f)))
|
||||
(stronger-prop (λ (this that) #f))))
|
||||
(define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([to-proj (λ (c) ((proj-get c) c))]
|
||||
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
|
||||
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
|
||||
(and rngs (map to-proj (get-case->-rng-ctcs ctc))))]
|
||||
[rst-ctcs (case->-rst-ctcs ctc)]
|
||||
[specs (case->-specs ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs)
|
||||
(map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))]
|
||||
[chk
|
||||
(λ (val mtd?)
|
||||
(cond
|
||||
[(null? specs)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected a procedure"))]
|
||||
[else
|
||||
(for-each
|
||||
(λ (dom-length has-rest?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str)
|
||||
(check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str)))
|
||||
specs rst-ctcs)]))])
|
||||
(apply (case->-wrapper ctc)
|
||||
chk
|
||||
projs)))))
|
||||
#:property name-prop
|
||||
(λ (ctc) (apply
|
||||
build-compound-type-name
|
||||
'case->
|
||||
(map (λ (dom rst range)
|
||||
(apply
|
||||
build-compound-type-name
|
||||
'->
|
||||
(append dom
|
||||
(if rst
|
||||
(list '#:rest rst)
|
||||
'())
|
||||
(list
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(and (pair? range) (null? (cdr range)))
|
||||
(car range)]
|
||||
[else (apply build-compound-type-name 'values range)])))))
|
||||
(case->-dom-ctcs ctc)
|
||||
(case->-rst-ctcs ctc)
|
||||
(case->-rng-ctcs ctc))))
|
||||
#:property first-order-prop (λ (ctc) (λ (val) #f))
|
||||
#:property stronger-prop (λ (this that) #f))
|
||||
|
||||
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
|
||||
(make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)
|
||||
|
|
|
|||
|
|
@ -33,8 +33,6 @@
|
|||
make-proj-contract
|
||||
build-flat-contract
|
||||
|
||||
define-struct/prop
|
||||
|
||||
contract-stronger?
|
||||
|
||||
contract-first-order-passes?
|
||||
|
|
@ -55,49 +53,6 @@
|
|||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
|
||||
|
||||
;; define-struct/prop is a define-struct-like macro that
|
||||
;; also allows properties to be defined
|
||||
;; it contains copied code (build-struct-names) in order to avoid
|
||||
;; a module cycle
|
||||
(define-syntax (define-struct/prop stx)
|
||||
(let ()
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ name (field ...) ((property value) ...))
|
||||
(andmap identifier? (syntax->list (syntax (field ...))))
|
||||
(let ([struct-names (build-struct-names (syntax name)
|
||||
(syntax->list (syntax (field ...)))
|
||||
#f
|
||||
#t
|
||||
stx)]
|
||||
[struct-names/bangers (build-struct-names (syntax name)
|
||||
(syntax->list (syntax (field ...)))
|
||||
#t
|
||||
#f
|
||||
stx)]
|
||||
[field-count/val (length (syntax->list (syntax (field ...))))])
|
||||
(with-syntax ([struct:-name (list-ref struct-names 0)]
|
||||
[struct-maker (list-ref struct-names 1)]
|
||||
[predicate (list-ref struct-names 2)]
|
||||
[(count ...) (nums-up-to field-count/val)]
|
||||
[(selectors ...) (cdddr struct-names)]
|
||||
[(bangers ...) (cdddr struct-names/bangers)]
|
||||
[field-count field-count/val]
|
||||
[(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))])
|
||||
(syntax
|
||||
(begin
|
||||
(define-values (struct:-name struct-maker predicate get set)
|
||||
(make-struct-type 'name
|
||||
#f ;; super
|
||||
field-count
|
||||
0 ;; auto-field-k
|
||||
'()
|
||||
(list (cons property value) ...)))
|
||||
(define selectors (make-struct-field-accessor get count 'field))
|
||||
...
|
||||
(define bangers (make-struct-field-mutator set count 'field))
|
||||
...))))])))
|
||||
|
||||
(define-values (proj-prop proj-pred? raw-proj-get)
|
||||
(make-struct-type-property 'contract-projection))
|
||||
(define-values (name-prop name-pred? name-get)
|
||||
|
|
@ -145,9 +100,14 @@
|
|||
[(contract? x) x]
|
||||
[(and (procedure? x) (procedure-arity-includes? x 1))
|
||||
(flat-contract x)]
|
||||
;[(symbol? x) (symbol-contract x)]
|
||||
;[(char? x) (char-contract x)]
|
||||
;[(boolean? x) (boolean-contract x)]
|
||||
;[(regexp? x) (regexp-contract x)]
|
||||
;[(string? x) (string-contract x)]
|
||||
[else
|
||||
(error name
|
||||
"expected contract or procedure of arity 1, got ~e"
|
||||
"expected contract or a value that can be coerced into one, got ~e"
|
||||
x)]))
|
||||
|
||||
(define-values (make-exn:fail:contract2
|
||||
|
|
@ -177,7 +137,12 @@
|
|||
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
|
||||
(let ([blame-src (src-info-as-string src-info)]
|
||||
[formatted-contract-sexp
|
||||
(let ([one-line (format "~s" contract-sexp)])
|
||||
(let ([one-line
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([pretty-print-print-line print-contract-liner]
|
||||
[pretty-print-columns 'infinity])
|
||||
(pretty-print contract-sexp sp)
|
||||
(get-output-string sp)))])
|
||||
(if (< (string-length one-line) 30)
|
||||
one-line
|
||||
(let ([sp (open-output-string)])
|
||||
|
|
@ -312,25 +277,33 @@
|
|||
(define-values (make-flat-contract
|
||||
make-proj-contract)
|
||||
(let ()
|
||||
(define-struct/prop proj-contract (the-name proj first-order-proc)
|
||||
((proj-prop (λ (ctc) (proj-contract-proj ctc)))
|
||||
(name-prop (λ (ctc) (proj-contract-the-name ctc)))
|
||||
(first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc)
|
||||
(λ (x) #t))))
|
||||
(stronger-prop (λ (this that)
|
||||
(and (proj-contract? that)
|
||||
(procedure-closure-contents-eq?
|
||||
(proj-contract-proj this)
|
||||
(proj-contract-proj that)))))))
|
||||
(define-struct proj-contract (the-name proj first-order-proc)
|
||||
#:property proj-prop
|
||||
(λ (ctc) (proj-contract-proj ctc))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (proj-contract-the-name ctc))
|
||||
|
||||
#:property first-order-prop
|
||||
(λ (ctc) (or (proj-contract-first-order-proc ctc)
|
||||
(λ (x) #t)))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (proj-contract? that)
|
||||
(procedure-closure-contents-eq?
|
||||
(proj-contract-proj this)
|
||||
(proj-contract-proj that)))))
|
||||
|
||||
(define-struct flat-contract (the-name predicate)
|
||||
#:property proj-prop flat-proj
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (flat-contract? that)
|
||||
(procedure-closure-contents-eq? (flat-contract-predicate this)
|
||||
(flat-contract-predicate that))))
|
||||
#:property name-prop (λ (ctc) (flat-contract-the-name ctc))
|
||||
#:property flat-prop (λ (ctc) (flat-contract-predicate ctc)))
|
||||
|
||||
(define-struct/prop flat-contract (the-name predicate)
|
||||
((proj-prop flat-proj)
|
||||
(stronger-prop (λ (this that)
|
||||
(and (flat-contract? that)
|
||||
(procedure-closure-contents-eq? (flat-contract-predicate this)
|
||||
(flat-contract-predicate that)))))
|
||||
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
|
||||
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
|
||||
(values make-flat-contract
|
||||
make-proj-contract)))
|
||||
|
||||
|
|
@ -398,22 +371,24 @@
|
|||
(λ (v) (proj (f v)))))]))))))
|
||||
|
||||
|
||||
(define-struct/prop and/c (ctcs)
|
||||
((proj-prop and-proj)
|
||||
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))))
|
||||
(first-order-prop (λ (ctc)
|
||||
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
|
||||
(λ (x)
|
||||
(andmap (λ (f) (f x)) tests)))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (and/c? that)
|
||||
(let ([this-ctcs (and/c-ctcs this)]
|
||||
[that-ctcs (and/c-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))))
|
||||
(define-struct and/c (ctcs)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop and-proj
|
||||
#:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
|
||||
(λ (x)
|
||||
(andmap (λ (f) (f x)) tests))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (and/c? that)
|
||||
(let ([this-ctcs (and/c-ctcs this)]
|
||||
[that-ctcs (and/c-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))
|
||||
|
||||
(define (and/c . fs)
|
||||
(for-each
|
||||
|
|
@ -447,12 +422,13 @@
|
|||
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
|
||||
(make-and/c contracts))]))
|
||||
|
||||
(define-struct/prop any/c ()
|
||||
((proj-prop double-any-curried-proj)
|
||||
(stronger-prop (λ (this that) (any/c? that)))
|
||||
(name-prop (λ (ctc) 'any/c))
|
||||
(first-order-prop (λ (ctc) (λ (val) #t)))
|
||||
(flat-prop (λ (ctc) (λ (x) #t)))))
|
||||
(define-struct any/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop double-any-curried-proj
|
||||
#:property stronger-prop (λ (this that) (any/c? that))
|
||||
#:property name-prop (λ (ctc) 'any/c)
|
||||
#:property first-order-prop (λ (ctc) (λ (val) #t))
|
||||
#:property flat-prop (λ (ctc) (λ (x) #t)))
|
||||
|
||||
(define any/c (make-any/c))
|
||||
|
||||
|
|
@ -468,12 +444,13 @@
|
|||
(none/c-name ctc)
|
||||
val))))
|
||||
|
||||
(define-struct/prop none/c (name)
|
||||
((proj-prop none-curried-proj)
|
||||
(stronger-prop (λ (this that) #t))
|
||||
(name-prop (λ (ctc) (none/c-name ctc)))
|
||||
(first-order-prop (λ (ctc) (λ (val) #f)))
|
||||
(flat-prop (λ (ctc) (λ (x) #f)))))
|
||||
(define-struct none/c (name)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop none-curried-proj
|
||||
#:property stronger-prop (λ (this that) #t)
|
||||
#:property name-prop (λ (ctc) (none/c-name ctc))
|
||||
#:property first-order-prop (λ (ctc) (λ (val) #f))
|
||||
#:property flat-prop (λ (ctc) (λ (x) #f)))
|
||||
|
||||
(define none/c (make-none/c 'none/c))
|
||||
|
||||
|
|
|
|||
|
|
@ -50,62 +50,65 @@
|
|||
[_
|
||||
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
|
||||
|
||||
(define-struct/prop object-contract (methods method-ctcs method-wrappers fields field-ctcs)
|
||||
((proj-prop
|
||||
(λ (ctc)
|
||||
(let ([meth-names (object-contract-methods ctc)]
|
||||
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
|
||||
[ctc-field-names (object-contract-fields ctc)]
|
||||
[field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str))
|
||||
meth-param-projs)]
|
||||
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
|
||||
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
|
||||
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) field-param-projs)])
|
||||
(λ (val)
|
||||
|
||||
(unless (object? val)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected an object, got ~e"
|
||||
val))
|
||||
|
||||
(let ([objs-mtds (interface->method-names (object-interface val))]
|
||||
[vtable (extract-vtable val)]
|
||||
[method-ht (extract-method-ht val)])
|
||||
(for-each (λ (m proj)
|
||||
(let ([index (hash-ref method-ht m #f)])
|
||||
(unless index
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected an object with method ~s"
|
||||
m))
|
||||
;; verify the first-order properties by apply the projection and
|
||||
;; throwing the result away. Without this, the contract wrappers
|
||||
;; just check the first-order properties of the wrappers, which is
|
||||
;; the wrong thing.
|
||||
(proj (vector-ref vtable index))))
|
||||
meth-names
|
||||
meth-projs))
|
||||
|
||||
(let ([fields (field-names val)])
|
||||
(for-each (λ (f)
|
||||
(unless (memq f fields)
|
||||
(define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let ([meth-names (object-contract-methods ctc)]
|
||||
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
|
||||
[ctc-field-names (object-contract-fields ctc)]
|
||||
[field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str))
|
||||
meth-param-projs)]
|
||||
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
|
||||
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
|
||||
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) field-param-projs)])
|
||||
(λ (val)
|
||||
|
||||
(unless (object? val)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected an object, got ~e"
|
||||
val))
|
||||
|
||||
(let ([objs-mtds (interface->method-names (object-interface val))]
|
||||
[vtable (extract-vtable val)]
|
||||
[method-ht (extract-method-ht val)])
|
||||
(for-each (λ (m proj)
|
||||
(let ([index (hash-ref method-ht m #f)])
|
||||
(unless index
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected an object with field ~s"
|
||||
f)))
|
||||
ctc-field-names))
|
||||
|
||||
(apply make-object cls val
|
||||
(map (λ (field proj) (proj (get-field/proc field val)))
|
||||
ctc-field-names field-projs))))))))
|
||||
(name-prop (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
|
||||
(object-contract-fields ctc)
|
||||
(object-contract-field-ctcs ctc))
|
||||
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
|
||||
(object-contract-methods ctc)
|
||||
(object-contract-method-ctcs ctc)))))
|
||||
(first-order-prop (λ (ctc) (λ (val) #f)))
|
||||
(stronger-prop (λ (this that) #f))))
|
||||
"expected an object with method ~s"
|
||||
m))
|
||||
;; verify the first-order properties by apply the projection and
|
||||
;; throwing the result away. Without this, the contract wrappers
|
||||
;; just check the first-order properties of the wrappers, which is
|
||||
;; the wrong thing.
|
||||
(proj (vector-ref vtable index))))
|
||||
meth-names
|
||||
meth-projs))
|
||||
|
||||
(let ([fields (field-names val)])
|
||||
(for-each (λ (f)
|
||||
(unless (memq f fields)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected an object with field ~s"
|
||||
f)))
|
||||
ctc-field-names))
|
||||
|
||||
(apply make-object cls val
|
||||
(map (λ (field proj) (proj (get-field/proc field val)))
|
||||
ctc-field-names field-projs)))))))
|
||||
#:property name-prop
|
||||
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
|
||||
(object-contract-fields ctc)
|
||||
(object-contract-field-ctcs ctc))
|
||||
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
|
||||
(object-contract-methods ctc)
|
||||
(object-contract-method-ctcs ctc))))
|
||||
|
||||
#:property first-order-prop (λ (ctc) (λ (val) #f))
|
||||
#:property stronger-prop (λ (this that) #f))
|
||||
|
||||
(define-syntax (object-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -175,16 +175,17 @@
|
|||
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
|
||||
(make-struct-type-property 'original-contract))
|
||||
|
||||
(define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp)
|
||||
((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)))
|
||||
(define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp)
|
||||
#:property proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))
|
||||
;; I think provide/contract and contract calls this, so we are in effect allocating
|
||||
;; the original once
|
||||
(name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc))))
|
||||
(orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))))
|
||||
(stronger-prop (λ (this that)
|
||||
(and (opt-contract? that)
|
||||
(eq? (opt-contract-stamp this) (opt-contract-stamp that))
|
||||
((opt-contract-stronger this) this that))))))
|
||||
#:property name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
|
||||
#:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -939,41 +939,45 @@ improve method arity mismatch contract violation error messages?
|
|||
[else
|
||||
(make-multi-or/c flat-contracts ho-contracts)])))]))
|
||||
|
||||
(define-struct/prop or/c (pred flat-ctcs ho-ctc)
|
||||
((proj-prop (λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[pred (or/c-pred ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
(define-struct or/c (pred flat-ctcs ho-ctc)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[pred (or/c-pred ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else
|
||||
(partial-contract val)]))))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(or/c-ho-ctc ctc)
|
||||
(or/c-flat-ctcs ctc)))
|
||||
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))]
|
||||
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
|
||||
(λ (x)
|
||||
(or (ho x)
|
||||
(ormap (λ (f) (f x)) flats)))))
|
||||
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(or/c-ho-ctc ctc)
|
||||
(or/c-flat-ctcs ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))]
|
||||
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
|
||||
(λ (x)
|
||||
(or (ho x)
|
||||
(ormap (λ (f) (f x)) flats))))))
|
||||
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (or/c? that)
|
||||
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
|
||||
(let ([this-ctcs (or/c-flat-ctcs this)]
|
||||
[that-ctcs (or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (or/c? that)
|
||||
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
|
||||
(let ([this-ctcs (or/c-flat-ctcs this)]
|
||||
[that-ctcs (or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
|
|
@ -1017,54 +1021,59 @@ improve method arity mismatch contract violation error messages?
|
|||
candidate-proc
|
||||
candidate-contract)]))]))))))
|
||||
|
||||
(define-struct/prop multi-or/c (flat-ctcs ho-ctcs)
|
||||
((proj-prop multi-or/c-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(append
|
||||
(multi-or/c-flat-ctcs ctc)
|
||||
(reverse (multi-or/c-ho-ctcs ctc))))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
|
||||
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
|
||||
(λ (x)
|
||||
(or (ormap (λ (f) (f x)) hos)
|
||||
(ormap (λ (f) (f x)) flats))))))
|
||||
|
||||
(stronger-prop
|
||||
(λ (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 (flat-ctcs ho-ctcs)
|
||||
#:property proj-prop multi-or/c-proj
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(append
|
||||
(multi-or/c-flat-ctcs ctc)
|
||||
(reverse (multi-or/c-ho-ctcs ctc)))))
|
||||
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
|
||||
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
|
||||
(λ (x)
|
||||
(or (ormap (λ (f) (f x)) hos)
|
||||
(ormap (λ (f) (f x)) flats)))))
|
||||
|
||||
#:property stronger-prop
|
||||
(λ (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/prop flat-or/c (pred flat-ctcs)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(flat-or/c-flat-ctcs ctc))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (flat-or/c? that)
|
||||
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
|
||||
[that-ctcs (flat-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))
|
||||
(flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
|
||||
(define-struct flat-or/c (pred flat-ctcs)
|
||||
#:property proj-prop flat-proj
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(flat-or/c-flat-ctcs ctc)))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (flat-or/c? that)
|
||||
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
|
||||
[that-ctcs (flat-or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs)))))
|
||||
|
||||
#:property flat-prop
|
||||
(λ (ctc) (flat-or/c-pred ctc)))
|
||||
|
||||
;;
|
||||
;; or/c opter
|
||||
|
|
@ -1240,29 +1249,32 @@ improve method arity mismatch contract violation error messages?
|
|||
[else (error 'one-of-pc "undef ~s" x)]))
|
||||
|
||||
|
||||
(define-struct/prop one-of/c (elems)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
`(,(cond
|
||||
[(andmap symbol? elems)
|
||||
'symbols]
|
||||
[else
|
||||
'one-of/c])
|
||||
,@(map one-of-pc elems)))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (one-of/c? that)
|
||||
(let ([this-elems (one-of/c-elems this)]
|
||||
[that-elems (one-of/c-elems that)])
|
||||
(and
|
||||
(andmap (λ (this-elem) (memv this-elem that-elems))
|
||||
this-elems)
|
||||
#t)))))
|
||||
(flat-prop
|
||||
(λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
(λ (x) (memv x elems)))))))
|
||||
(define-struct one-of/c (elems)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop flat-proj
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
`(,(cond
|
||||
[(andmap symbol? elems)
|
||||
'symbols]
|
||||
[else
|
||||
'one-of/c])
|
||||
,@(map one-of-pc elems))))
|
||||
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (one-of/c? that)
|
||||
(let ([this-elems (one-of/c-elems this)]
|
||||
[that-elems (one-of/c-elems that)])
|
||||
(and
|
||||
(andmap (λ (this-elem) (memv this-elem that-elems))
|
||||
this-elems)
|
||||
#t))))
|
||||
#:property flat-prop
|
||||
(λ (ctc)
|
||||
(let ([elems (one-of/c-elems ctc)])
|
||||
(λ (x) (memv x elems)))))
|
||||
|
||||
(define printable/c
|
||||
(flat-named-contract
|
||||
|
|
@ -1286,27 +1298,32 @@ improve method arity mismatch contract violation error messages?
|
|||
(and (box? x)
|
||||
(printable? (unbox x))))))))
|
||||
|
||||
(define-struct/prop between/c (low high)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
(cond
|
||||
[(= n -inf.0) `(<=/c ,m)]
|
||||
[(= m +inf.0) `(>=/c ,n)]
|
||||
[(= n m) `(=/c ,n)]
|
||||
[else `(between/c ,n ,m)]))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (between/c? that)
|
||||
(<= (between/c-low that) (between/c-low this))
|
||||
(<= (between/c-high this) (between/c-high that)))))
|
||||
(flat-prop (λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(<= n x m))))))))
|
||||
(define-struct between/c (low high)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop flat-proj
|
||||
#:property name-prop
|
||||
(λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
(cond
|
||||
[(= n -inf.0) `(<=/c ,m)]
|
||||
[(= m +inf.0) `(>=/c ,n)]
|
||||
[(= n m) `(=/c ,n)]
|
||||
[else `(between/c ,n ,m)])))
|
||||
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (between/c? that)
|
||||
(<= (between/c-low that) (between/c-low this))
|
||||
(<= (between/c-high this) (between/c-high that))))
|
||||
|
||||
#:property flat-prop
|
||||
(λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(<= n x m))))))
|
||||
|
||||
(define-syntax (check-unary-between/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1922,37 +1939,40 @@ improve method arity mismatch contract violation error messages?
|
|||
(define (parameter/c x)
|
||||
(make-parameter/c (coerce-contract 'parameter/c x)))
|
||||
|
||||
(define-struct/prop parameter/c (ctc)
|
||||
((proj-prop (λ (ctc)
|
||||
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
|
||||
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
(make-derived-parameter
|
||||
val
|
||||
partial-neg-contract
|
||||
partial-pos-contract)]
|
||||
[else
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected a parameter")])))))))
|
||||
(name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
|
||||
(λ (x)
|
||||
(and (parameter? x)
|
||||
(tst (x)))))))
|
||||
(define-struct parameter/c (ctc)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
|
||||
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
(make-derived-parameter
|
||||
val
|
||||
partial-neg-contract
|
||||
partial-pos-contract)]
|
||||
[else
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"expected a parameter")]))))))
|
||||
|
||||
#:property name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
|
||||
(λ (x)
|
||||
(and (parameter? x)
|
||||
(tst (x))))))
|
||||
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
;; must be invariant (because the library doesn't currently split out pos/neg contracts
|
||||
;; which could be tested individually ....)
|
||||
(and (parameter/c? that)
|
||||
(contract-stronger? (parameter/c-ctc this)
|
||||
(parameter/c-ctc that))
|
||||
(contract-stronger? (parameter/c-ctc that)
|
||||
(parameter/c-ctc this)))))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
;; must be invariant (because the library doesn't currently split out pos/neg contracts
|
||||
;; which could be tested individually ....)
|
||||
(and (parameter/c? that)
|
||||
(contract-stronger? (parameter/c-ctc this)
|
||||
(parameter/c-ctc that))
|
||||
(contract-stronger? (parameter/c-ctc that)
|
||||
(parameter/c-ctc this)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user