From 06a4d0df4af94534e6186463a19b5c6982f1c65a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 13 Sep 2008 16:29:01 +0000 Subject: [PATCH] got rid of define-struct/prop since scheme/base has a define-struct that does all that (and more) now svn: r11727 --- collects/mzlib/private/contract-arrow.ss | 116 +++--- collects/scheme/private/contract-arrow.ss | 410 +++++++++++---------- collects/scheme/private/contract-guts.ss | 163 ++++---- collects/scheme/private/contract-object.ss | 113 +++--- collects/scheme/private/contract-opt.ss | 17 +- collects/scheme/private/contract.ss | 334 +++++++++-------- 6 files changed, 585 insertions(+), 568 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index ae0350cf62..edacb460ff 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -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 diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 7dc86ea518..87860226a2 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -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) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 522a87e254..876e10a1c5 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -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)) diff --git a/collects/scheme/private/contract-object.ss b/collects/scheme/private/contract-object.ss index 9e12860e6f..d3af2da8dc 100644 --- a/collects/scheme/private/contract-object.ss +++ b/collects/scheme/private/contract-object.ss @@ -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 () diff --git a/collects/scheme/private/contract-opt.ss b/collects/scheme/private/contract-opt.ss index d24c1d5e87..d61994a82a 100644 --- a/collects/scheme/private/contract-opt.ss +++ b/collects/scheme/private/contract-opt.ss @@ -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) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index e3e44173b8..6484671245 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -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)))))