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