suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Updated arrow.ss to new properties.

Browse Source 
svn: r17688
This commit is contained in:
Carl Eastlund 2010-01-17 04:17:40 +00:00
parent d10eea83e7
commit ed47b31635
1 changed files with 219 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

447
collects/scheme/contract/private/arrow.ss
View File

@ -48,11 +48,13 @@ v4 todo:
[(p-app-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(make-proj-contract (simple-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) #:name
(λ (pos-blame neg-blame src-info orig-str positive-position?) (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...) #:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val) (λ (val)
(if (procedure? val) (if (procedure? val)
(make-keyword-procedure (make-keyword-procedure
@ -62,11 +64,10 @@ v4 todo:
(λ args (λ args
(let-values ([(res-x ...) (apply val args)]) (let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))) (values (p-app-x res-x) ...))))
(raise-contract-error val (raise-blame-error blame
src-info val
pos-blame "expected a procedure")))))
orig-str #:first-order
"expected a procedure")))))
procedure?))))])) procedure?))))]))
@ -100,81 +101,83 @@ v4 todo:
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(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) (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 #:omit-define-syntaxes
#:property proj-prop #:property prop:contract
(λ (ctc) (build-contract-property
(let* ([doms-proj (map (λ (x) ((proj-get x) x)) #:projection
(if (->-dom-rest/c ctc) (λ (ctc)
(let* ([doms-proj (map contract-projection
(if (->-dom-rest/c ctc)
(append (->-doms/c ctc) (list (->-dom-rest/c ctc))) (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
(->-doms/c ctc)))] (->-doms/c ctc)))]
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] [doms-optional-proj (map contract-projection (->-optional-doms/c ctc))]
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] [rngs-proj (map contract-projection (->-rngs/c ctc))]
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] [mandatory-kwds-proj (map contract-projection (->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))] [optional-kwds-proj (map contract-projection (->-optional-kwds/c ctc))]
[mandatory-keywords (->-mandatory-kwds ctc)] [mandatory-keywords (->-mandatory-kwds ctc)]
[optional-keywords (->-optional-kwds ctc)] [optional-keywords (->-optional-kwds ctc)]
[func (->-func ctc)] [func (->-func ctc)]
[dom-length (length (->-doms/c ctc))] [dom-length (length (->-doms/c ctc))]
[optionals-length (length (->-optional-doms/c ctc))] [optionals-length (length (->-optional-doms/c ctc))]
[has-rest? (and (->-dom-rest/c ctc) #t)]) [has-rest? (and (->-dom-rest/c ctc) #t)])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) (let ([partial-doms (map (λ (dom) (dom (blame-swap blame)))
doms-proj)] doms-proj)]
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) [partial-optional-doms (map (λ (dom) (dom (blame-swap blame)))
doms-optional-proj)] doms-optional-proj)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?)) [partial-ranges (map (λ (rng) (rng blame))
rngs-proj)] rngs-proj)]
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) [partial-mandatory-kwds (map (λ (kwd) (kwd (blame-swap blame)))
mandatory-kwds-proj)] mandatory-kwds-proj)]
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) [partial-optional-kwds (map (λ (kwd) (kwd (blame-swap blame)))
optional-kwds-proj)]) optional-kwds-proj)])
(apply func (apply func
(λ (val mtd?) (λ (val mtd?)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)))
(append partial-doms partial-optional-doms (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges)))))) partial-ranges))))))
#:property name-prop #:name
(λ (ctc) (single-arrow-name-maker (λ (ctc) (single-arrow-name-maker
(->-doms/c ctc) (->-doms/c ctc)
(->-optional-doms/c ctc) (->-optional-doms/c ctc)
(->-dom-rest/c ctc) (->-dom-rest/c ctc)
(->-mandatory-kwds/c ctc) (->-mandatory-kwds/c ctc)
(->-mandatory-kwds ctc) (->-mandatory-kwds ctc)
(->-optional-kwds/c ctc) (->-optional-kwds/c ctc)
(->-optional-kwds ctc) (->-optional-kwds ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs/c ctc))) (->-rngs/c ctc)))
#:property first-order-prop #:first-order
(λ (ctc) (λ (ctc)
(λ (x) (λ (x)
(let ([l (length (->-doms/c ctc))]) (let ([l (length (->-doms/c ctc))])
(and (procedure? x) (and (procedure? x)
(if (->-dom-rest/c ctc) (if (->-dom-rest/c ctc)
(procedure-accepts-and-more? x l) (procedure-accepts-and-more? x l)
(procedure-arity-includes? x l)) (procedure-arity-includes? x l))
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)]) (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc)) (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords)) (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
(->-mandatory-kwds ctc)))) (->-mandatory-kwds ctc))))
#t)))) #t))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
(= (length (->-doms/c that)) (length (->-doms/c this))) (= (length (->-doms/c that)) (length (->-doms/c this)))
(andmap contract-stronger? (->-doms/c that) (->-doms/c this)) (andmap contract-stronger? (->-doms/c that) (->-doms/c this))
(equal? (->-mandatory-kwds this) (->-mandatory-kwds that)) (equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
(andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this)) (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
(equal? (->-optional-kwds this) (->-optional-kwds that)) (equal? (->-optional-kwds this) (->-optional-kwds that))
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this)) (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
(= (length (->-rngs/c that)) (length (->-rngs/c this))) (= (length (->-rngs/c that)) (length (->-rngs/c this)))
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))) (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))))
(define (build--> name (define (build--> name
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
@ -435,16 +438,14 @@ v4 todo:
(append partials-rngs partial) (append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos (opt/info-pos opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars) ((rng-arg ...) rng-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars)) (dom-len (length dom-vars))
((next-rng ...) next-rngs)) ((next-rng ...) next-rngs))
(syntax (begin (syntax (begin
(check-procedure val #f dom-len 0 '() '() #| keywords |# src-info pos orig-str) (check-procedure val #f dom-len 0 '() '() #| keywords |# blame)
(λ (dom-arg ...) (λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)]) (let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...)))))) (values next-rng ...))))))
@ -485,14 +486,12 @@ v4 todo:
(append partials-doms partial) (append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos (opt/info-pos opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
(syntax (begin (syntax (begin
(check-procedure val #f dom-len 0 '() '() #|keywords|# src-info pos orig-str) (check-procedure val #f dom-len 0 '() '() #|keywords|# blame)
(λ (dom-arg ...) (λ (dom-arg ...)
(val next-dom ...))))) (val next-dom ...)))))
lifts-doms lifts-doms
@ -855,7 +854,7 @@ v4 todo:
(list (+ mandatory-count i))] (list (+ mandatory-count i))]
[else [else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([this->d-id (gensym '->d-tail-key)]) (let ([this->d-id (gensym '->d-tail-key)])
(λ (val) (λ (val)
(check-procedure val (check-procedure val
@ -864,7 +863,7 @@ v4 todo:
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct) (->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct) (->d-optional-keywords ->d-stct)
src-info pos-blame orig-str) blame)
(let ([kwd-proc (let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args) (λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct) (let* ([orig-args (if (->d-mtd? ->d-stct)
@ -889,7 +888,7 @@ v4 todo:
[(or (null? building-kwd-args) (null? all-kwds)) '()] [(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds) [else (if (eq? (car all-kwds)
(car building-kwd-args)) (car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str (not positive-position?)) (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))])) (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
@ -906,17 +905,17 @@ v4 todo:
(cond (cond
[(null? args) [(null? args)
(if (->d-rest-ctc ->d-stct) (if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str (not positive-position?)) (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
'())] '())]
[(null? non-kwd-ctcs) [(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct) (if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str (not positive-position?)) (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
;; ran out of arguments, but don't have a rest parameter. ;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is ;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen. ;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))] (error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str (not positive-position?)) [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
(loop (cdr args) (loop (cdr args)
(cdr non-kwd-ctcs)))])))))] (cdr non-kwd-ctcs)))])))))]
[rng (let ([rng (->d-range ->d-stct)]) [rng (let ([rng (->d-range ->d-stct)])
@ -929,12 +928,10 @@ v4 todo:
[rng-underscore? (box? (->d-range ->d-stct))]) [rng-underscore? (box? (->d-range ->d-stct))])
(when (->d-pre-cond ->d-stct) (when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args) (unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val (raise-blame-error blame
src-info val
neg-blame "#:pre-cond violation~a"
orig-str (build-values-string ", argument" dep-pre-args))))
"#:pre-cond violation~a"
(build-values-string ", argument" dep-pre-args))))
(call-with-immediate-continuation-mark (call-with-immediate-continuation-mark
->d-tail-key ->d-tail-key
(λ (first-mark) (λ (first-mark)
@ -956,25 +953,21 @@ v4 todo:
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct) (when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args) (unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val (raise-blame-error blame
src-info val
pos-blame "#:post-cond violation~a~a"
orig-str (build-values-string ", argument" dep-pre-args)
"#:post-cond violation~a~a" (build-values-string (if (null? dep-pre-args)
(build-values-string ", argument" dep-pre-args) ", result"
(build-values-string (if (null? dep-pre-args) "\n result")
", result" orig-results))))
"\n result")
orig-results))))
(unless (= range-count (length orig-results)) (unless (= range-count (length orig-results))
(raise-contract-error val (raise-blame-error blame
src-info val
pos-blame "expected ~a results, got ~a"
orig-str range-count
"expected ~a results, got ~a" (length orig-results)))
range-count
(length orig-results)))
(apply (apply
values values
(let loop ([results orig-results] (let loop ([results orig-results]
@ -985,7 +978,8 @@ v4 todo:
(cons (cons
(invoke-dep-ctc (car result-contracts) (invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args) (if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str positive-position?) (car results)
blame)
(loop (cdr results) (cdr result-contracts)))]))))))] (loop (cdr results) (cdr result-contracts)))]))))))]
[else [else
(thunk)])))))]) (thunk)])))))])
@ -1014,11 +1008,11 @@ v4 todo:
(loop (cdr lst)))])))])) (loop (cdr lst)))])))]))
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str positive-position?) (define (invoke-dep-ctc dep-ctc dep-args val blame)
(let ([ctc (coerce-contract '->d (if dep-args (let ([ctc (coerce-contract '->d (if dep-args
(apply dep-ctc dep-args) (apply dep-ctc dep-args)
dep-ctc))]) dep-ctc))])
((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str positive-position?) val))) (((contract-projection ctc) blame) val)))
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
@ -1090,58 +1084,60 @@ v4 todo:
name-wrapper) ;; (-> proc proc) name-wrapper) ;; (-> proc proc)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop ->d-proj #:property prop:contract
#:property name-prop (build-contract-property
(λ (ctc) #:projection ->d-proj
(let* ([counting-id 'x] #:name
[ids '(x y z w)] (λ (ctc)
[next-id (let* ([counting-id 'x]
(λ () [ids '(x y z w)]
(cond [next-id
[(pair? ids) (λ ()
(begin0 (car ids) (cond
(set! ids (cdr ids)))] [(pair? ids)
[(null? ids) (begin0 (car ids)
(begin0 (set! ids (cdr ids)))]
(string->symbol (format "~a0" counting-id)) [(null? ids)
(set! ids 1))] (begin0
[else (string->symbol (format "~a0" counting-id))
(begin0 (set! ids 1))]
(string->symbol (format "~a~a" counting-id ids)) [else
(set! ids (+ ids 1)))]))]) (begin0
`(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) (string->symbol (format "~a~a" counting-id ids))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) (set! ids (+ ids 1)))]))])
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) `(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
,@(if (->d-rest-ctc 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) '...) (list '#:rest (next-id) '...)
'()) '())
,@(if (->d-pre-cond ctc) ,@(if (->d-pre-cond ctc)
(list '#:pre-cond '...) (list '#:pre-cond '...)
(list)) (list))
,(let ([range (->d-range ctc)]) ,(let ([range (->d-range ctc)])
(cond (cond
[(not range) 'any] [(not range) 'any]
[(box? range) [(box? range)
(let ([range (unbox range)]) (let ([range (unbox range)])
(cond (cond
[(and (not (null? range)) [(and (not (null? range))
(null? (cdr range))) (null? (cdr range)))
`[_ ...]] `[_ ...]]
[else [else
`(values ,@(map (λ (x) `(_ ...)) range))]))] `(values ,@(map (λ (x) `(_ ...)) range))]))]
[(and (not (null? range)) [(and (not (null? range))
(null? (cdr range))) (null? (cdr range)))
`[,(next-id) ...]] `[,(next-id) ...]]
[else [else
`(values ,@(map (λ (x) `(,(next-id) ...)) range))])) `(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
,@(if (->d-post-cond ctc) ,@(if (->d-post-cond ctc)
(list '#:post-cond '...) (list '#:post-cond '...)
(list))))) (list)))))
#:property first-order-prop (λ (ctc) (λ (x) #f)) #:first-order (λ (ctc) (λ (x) #f))
#:property stronger-prop (λ (this that) (eq? this that))) #:stronger (λ (this that) (eq? this that))))
; ;
@ -1249,60 +1245,59 @@ v4 todo:
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections ;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
(define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper) (define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop #:property prop:contract
(λ (ctc) (build-contract-property
(let* ([to-proj (λ (c) ((proj-get c) c))] #:projection
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))] (λ (ctc)
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) (let* ([dom-ctcs (map contract-projection (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 contract-projection (get-case->-rng-ctcs ctc))))]
[specs (case->-specs ctc)]) [rst-ctcs (case->-rst-ctcs ctc)]
(λ (pos-blame neg-blame src-info orig-str positive-position?) [specs (case->-specs ctc)])
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str (not positive-position?))) dom-ctcs) (λ (blame)
(map (λ (f) (f pos-blame neg-blame src-info orig-str positive-position?)) rng-ctcs))] (let ([projs (append (map (λ (f) (f (blame-swap blame))) dom-ctcs)
[chk (map (λ (f) (f blame)) 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-blame-error blame val "expected a procedure"))]
pos-blame [else
orig-str (for-each
"expected a procedure"))] (λ (dom-length has-rest?)
[else (if has-rest?
(for-each (check-procedure/more val mtd? dom-length '() '() blame)
(λ (dom-length has-rest?) (check-procedure val mtd? dom-length 0 '() '() blame)))
(if has-rest? specs rst-ctcs)]))])
(check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str) (apply (case->-wrapper ctc)
(check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str))) chk
specs rst-ctcs)]))]) projs)))))
(apply (case->-wrapper ctc) #:name
chk (λ (ctc)
projs))))) (apply
#:property name-prop build-compound-type-name
(λ (ctc) (apply 'case->
build-compound-type-name (map (λ (dom rst range)
'case-> (apply
(map (λ (dom rst range) build-compound-type-name
(apply '->
build-compound-type-name (append dom
'-> (if rst
(append dom (list '#:rest rst)
(if rst '())
(list '#:rest rst) (list
'()) (cond
(list [(not range) 'any]
(cond [(and (pair? range) (null? (cdr range)))
[(not range) 'any] (car range)]
[(and (pair? range) (null? (cdr range))) [else (apply build-compound-type-name 'values range)])))))
(car range)] (case->-dom-ctcs ctc)
[else (apply build-compound-type-name 'values range)]))))) (case->-rst-ctcs ctc)
(case->-dom-ctcs ctc) (case->-rng-ctcs ctc))))
(case->-rst-ctcs ctc)
(case->-rng-ctcs ctc)))) #:first-order (λ (ctc) (λ (val) #f))
#:property first-order-prop (λ (ctc) (λ (val) #f)) #:stronger (λ (this that) #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)
@ -1459,15 +1454,13 @@ v4 todo:
(let-values ([(mandatory optional) (procedure-keywords f)]) (let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory))) (null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) (define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val)) (keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error (raise-blame-error
val
src-info
blame blame
orig-str val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure") (if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length) (if (zero? dom-length) "no" dom-length)
@ -1522,15 +1515,13 @@ v4 todo:
", and " ", and "
(format-keywords-error 'optional optional-keywords))])) (format-keywords-error 'optional optional-keywords))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds src-info blame orig-str) (define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val)) (keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error (raise-blame-error
val
src-info
blame blame
orig-str val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure") (if mtd? "method" "procedure")
(cond (cond