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

Don't use syntax parameters for method contracts.

Browse Source 
Can be done with plain old functions.
This commit is contained in:
Vincent St-Amour 2016-03-30 15:38:31 -05:00
parent 0aec872710
commit 209f2db611
7 changed files with 180 additions and 178 deletions

98
racket/collects/racket/contract/private/arr-d.rkt
View File

@ -12,6 +12,7 @@
"arrow-common.rkt") "arrow-common.rkt")
(provide ->d (provide ->d
(for-syntax ->d-internal) ; for ->dm
base-->d? ->d-name) ; for object-contract base-->d? ->d-name) ; for object-contract
; ;
@ -132,6 +133,11 @@
(datum->syntax sstx (cons #'this-arg #'args) sstx)]))))) (datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
(define-syntax (->d stx) (define-syntax (->d stx)
(syntax-case stx ()
[(_ . args)
(->d-internal (syntax/loc stx (->d . args)) #|method?|# #f)]))
(define-for-syntax (->d-internal stx maybe-this-param) ; non-#f is creating an ->dm
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-doms ...) [(_ (raw-mandatory-doms ...)
. .
@ -148,9 +154,9 @@
#'((optional-kwd optional-kwd-id) ... #'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))] (mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...) [(this-parameter ...)
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method)) (if maybe-this-param
(car (generate-temporaries '(this))) (generate-temporaries '(this))
(datum->syntax stx 'this #f)))]) null)])
(with-syntax ([(dom-params ...) (with-syntax ([(dom-params ...)
#`(this-parameter ... #`(this-parameter ...
mandatory-regular-id ... mandatory-regular-id ...
@ -167,8 +173,7 @@
[any #'(() #f)] [any #'(() #f)]
[[id ctc] #'((id) (ctc))] [[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (and (syntax-parameter-value #'making-a-method) #t)] [mtd? (and maybe-this-param #t)])
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)])
(let ([rng-underscores? (let ([rng-underscores?
(let ([is-underscore? (let ([is-underscore?
(λ (x) (λ (x)
@ -195,7 +200,7 @@
(when dup (when dup
(raise-syntax-error #f "duplicate identifier" stx dup))) (raise-syntax-error #f "duplicate identifier" stx dup)))
#`(let-syntax ([parameterize-this #`(let-syntax ([parameterize-this
(let ([old-param (syntax-parameter-value #'making-a-method)]) (let ([old-param #,maybe-this-param])
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(_ body) #'body] [(_ body) #'body]
@ -207,44 +212,42 @@
([param (make-this-transformer #'id)]) ([param (make-this-transformer #'id)])
body))) body)))
#'body)])))]) #'body)])))])
(syntax-parameterize (build-->d mtd?
((making-a-method #f)) (list (λ (dom-params ...)
(build-->d mtd? ->m-ctc? (parameterize-this this-parameter ... mandatory-doms)) ...)
(list (λ (dom-params ...) (list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-doms)) ...) (parameterize-this this-parameter ... optional-doms)) ...)
(list (λ (dom-params ...) (list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-doms)) ...) (parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
(list (λ (dom-params ...) (list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...) (parameterize-this this-parameter ... optional-kwd-dom)) ...)
(list (λ (dom-params ...) #,(if id/rest
(parameterize-this this-parameter ... optional-kwd-dom)) ...) (with-syntax ([(id rst-ctc) id/rest])
#,(if id/rest #`(λ (dom-params ...)
(with-syntax ([(id rst-ctc) id/rest]) (parameterize-this this-parameter ... rst-ctc)))
#`(λ (dom-params ...) #f)
(parameterize-this this-parameter ... rst-ctc))) #,(if pre-cond
#f) #`(λ (dom-params ...)
#,(if pre-cond (parameterize-this this-parameter ... #,pre-cond))
#`(λ (dom-params ...) #f)
(parameterize-this this-parameter ... #,pre-cond)) #,(syntax-case #'rng-ctcs ()
#f) [#f #f]
#,(syntax-case #'rng-ctcs () [(ctc ...)
[#f #f] (if rng-underscores?
[(ctc ...) #'(box (list (λ (dom-params ...)
(if rng-underscores? (parameterize-this this-parameter ... ctc)) ...))
#'(box (list (λ (dom-params ...) #'(list (λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... ctc)) ...)) (parameterize-this this-parameter ... ctc)) ...))])
#'(list (λ (rng-params ... dom-params ...) #,(if post-cond
(parameterize-this this-parameter ... ctc)) ...))]) #`(λ (rng-params ... dom-params ...)
#,(if post-cond (parameterize-this this-parameter ... #,post-cond))
#`(λ (rng-params ... dom-params ...) #f)
(parameterize-this this-parameter ... #,post-cond)) '(mandatory-kwd ...)
#f) '(optional-kwd ...)
'(mandatory-kwd ...) (λ (f)
'(optional-kwd ...) #,(add-name-prop
(λ (f) (syntax-local-infer-name stx)
#,(add-name-prop #`(λ args (apply f args))))))))))))]))
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))))))))))]))
(define ((late-neg-->d-proj wrap-procedure) ->d-stct) (define ((late-neg-->d-proj wrap-procedure) ->d-stct)
(let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))] (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))]
@ -462,7 +465,7 @@
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args))) (cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))])))) (cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
(define (build-->d mtd? mctc? (define (build-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs mandatory-dom-ctcs optional-dom-ctcs
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
rest-ctc pre-cond range post-cond rest-ctc pre-cond range post-cond
@ -473,7 +476,7 @@
(append mandatory-kwds optional-kwds) (append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))]) (λ (x y) (keyword<? (car x) (car y))))])
(make-impersonator-->d mtd? mctc? (make-impersonator-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs) (map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond rest-ctc pre-cond range post-cond
@ -484,7 +487,7 @@
;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt ;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt
(define ((->d-name print-as-method-if-method?) ctc) (define ((->d-name print-as-method-if-method?) ctc)
(let* ([name (if (and (base-->d-mctc? ctc) print-as-method-if-method?) '->dm '->d)] (let* ([name (if (and (base-->d-mtd? ctc) print-as-method-if-method?) '->dm '->d)]
[counting-id 'x] [counting-id 'x]
[ids '(x y z w)] [ids '(x y z w)]
[next-id [next-id
@ -550,7 +553,6 @@
;; 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 base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. (define-struct base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mctc? ;; boolean; indicates if this contract was constructed with ->dm (from racket/class)
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))

26
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -25,7 +25,8 @@
[module-identifier-mapping-put! free-identifier-mapping-put!] [module-identifier-mapping-put! free-identifier-mapping-put!]
[module-identifier-mapping-for-each free-identifier-mapping-for-each]))) [module-identifier-mapping-for-each free-identifier-mapping-for-each])))
(provide (rename-out [->i/m ->i])) (provide (rename-out [->i/m ->i])
(for-syntax ->i-internal)) ; for method version of ->i
(define (build-??-args c-or-i-procedure ctc blame) (define (build-??-args c-or-i-procedure ctc blame)
(define arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x))) (define arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x)))
@ -841,7 +842,7 @@ evaluted left-to-right.)
body))] body))]
[else stx])) [else stx]))
(define-for-syntax (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars) (define-for-syntax (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?)
(define-values (wrapper-proc-arglist (define-values (wrapper-proc-arglist
blame-ids args+rst blame-ids args+rst
@ -864,8 +865,7 @@ evaluted left-to-right.)
(generate-temporaries (map arg/res-var ordered-ress))) (generate-temporaries (map arg/res-var ordered-ress)))
(define this-param (and (syntax-parameter-value #'making-a-method) (define this-param (and method? (car (generate-temporaries '(this)))))
(car (generate-temporaries '(this)))))
(define wrapper-body (define wrapper-body
(add-wrapper-let (add-wrapper-let
@ -899,7 +899,7 @@ evaluted left-to-right.)
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party)) (define blame+neg-party (cons blame neg-party))
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,method?)
(c-or-i-procedure (c-or-i-procedure
val val
(let ([arg-checker (let ([arg-checker
@ -1026,7 +1026,7 @@ evaluted left-to-right.)
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
res-proj-vars indy-res-proj-vars)) res-proj-vars indy-res-proj-vars))
(define-for-syntax (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars) (define-for-syntax (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?)
(define-values (wrapper-proc-arglist (define-values (wrapper-proc-arglist
blame-ids args+rst blame-ids args+rst
ordered-args arg-indices ordered-args arg-indices
@ -1048,8 +1048,7 @@ evaluted left-to-right.)
(generate-temporaries (map arg/res-var ordered-ress))) (generate-temporaries (map arg/res-var ordered-ress)))
(define this-param (and (syntax-parameter-value #'making-a-method) (define this-param (and method? (car (generate-temporaries '(this)))))
(car (generate-temporaries '(this)))))
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (f) (λ (f)
@ -1138,10 +1137,15 @@ evaluted left-to-right.)
vars)) vars))
(define-syntax (->i/m stx) (define-syntax (->i/m stx)
(syntax-case stx ()
[(_ . args)
(->i-internal (syntax/loc stx (->i . args)) #|method?|# #f)]))
(define-for-syntax (->i-internal stx method?)
(define an-istx (parse-->i stx)) (define an-istx (parse-->i stx))
(define used-indy-vars (mk-used-indy-vars an-istx)) (define used-indy-vars (mk-used-indy-vars an-istx))
(define-values (blame-ids wrapper-func) (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars)) (define-values (blame-ids wrapper-func) (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?))
(define val-first-wrapper-func (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars)) (define val-first-wrapper-func (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?))
(define args+rst (append (istx-args an-istx) (define args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)
(list (istx-rst an-istx)) (list (istx-rst an-istx))
@ -1311,7 +1315,7 @@ evaluted left-to-right.)
(istx-args an-istx))) (istx-args an-istx)))
keyword<?) keyword<?)
'#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx))) '#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx)))
#,(and (syntax-parameter-value #'making-a-method) #t) #,method?
(quote-module-name) (quote-module-name)
#,wrapper-func #,wrapper-func
#,val-first-wrapper-func #,val-first-wrapper-func

10
racket/collects/racket/contract/private/arrow-common.rkt
View File

@ -8,8 +8,7 @@
racket/stxparam) racket/stxparam)
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(provide making-a-method method-contract? (for-syntax make-this-parameters) (provide blame-add-range-context
blame-add-range-context
blame-add-nth-arg-context blame-add-nth-arg-context
check-procedure check-procedure/more check-procedure check-procedure/more
procedure-accepts-and-more? procedure-accepts-and-more?
@ -27,13 +26,6 @@
(define-struct unsupplied-arg ()) (define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg)) (define the-unsupplied-arg (make-unsupplied-arg))
(define-syntax-parameter making-a-method #f)
(define-syntax-parameter method-contract? #f)
(define-for-syntax (make-this-parameters id)
(if (syntax-parameter-value #'making-a-method)
(list id)
null))
(define (blame-add-range-context blame) (define (blame-add-range-context blame)
(blame-add-context blame "the range of")) (blame-add-context blame "the range of"))

97
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -14,7 +14,7 @@
(prefix-in arrow: "arrow-common.rkt")) (prefix-in arrow: "arrow-common.rkt"))
(provide (rename-out [->/c ->]) ->* (provide (rename-out [->/c ->]) ->*
->-internal ->*-internal ; for ->m and ->*m (for-syntax ->-internal ->*-internal) ; for ->m and ->*m
base->? base->-name base->-rngs base->-doms base->? base->-name base->-rngs base->-doms
dynamic->* dynamic->*
arity-checking-wrapper arity-checking-wrapper
@ -644,17 +644,12 @@
(define-syntax (->/c stx) (define-syntax (->/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ . args)
(let () (->-internal (syntax/loc stx (-> . args)) #|method?|# #f)]))
#`(syntax-parameterize
((arrow:making-a-method #f))
#,(quasisyntax/loc stx
(->-internal -> . args))))]))
(define-syntax (->-internal stx*) (define-for-syntax (->-internal stx method?)
(syntax-case stx* () (syntax-case stx ()
[(_ orig-> args ... rng) [(_ args ... rng)
(let () (let ()
(define stx (syntax/loc stx* (orig-> args ... rng)))
(define this-> (gensym 'this->)) (define this-> (gensym 'this->))
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info) (define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
(parse-arrow-args stx (syntax->list #'(args ...)) this->)) (parse-arrow-args stx (syntax->list #'(args ...)) this->))
@ -666,29 +661,26 @@
[any #f] [any #f]
[(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))] [(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))]
[rng (add-pos-obligations (list #'rng))])) [rng (add-pos-obligations (list #'rng))]))
(define method? (syntax-parameter-value #'arrow:making-a-method))
(define-values (plus-one-arity-function chaperone-constructor) (define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor (build-plus-one-arity-function+chaperone-constructor
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f
method?)) method?))
(syntax-property (syntax-property
#`(syntax-parameterize #`(let #,let-bindings
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one #,(quasisyntax/loc stx
(let #,let-bindings (build-simple-->
#,(quasisyntax/loc stx (list #,@regular-args)
(build-simple--> '(#,@kwds)
(list #,@regular-args) (list #,@kwd-args)
'(#,@kwds) #,(if rngs
(list #,@kwd-args) #`(list #,@rngs)
#,(if rngs #'#f)
#`(list #,@rngs) #,plus-one-arity-function
#'#f) #,chaperone-constructor
#,plus-one-arity-function #,(if ellipsis-info
#,chaperone-constructor #`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
#,(if ellipsis-info #'#f)
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info) #,method?)))
#'#f)
#,method?))))
'racket/contract:contract 'racket/contract:contract
(vector this-> (vector this->
;; the -> in the original input to this guy ;; the -> in the original input to this guy
@ -835,13 +827,9 @@
(define-syntax (->* stx) (define-syntax (->* stx)
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ . args)
#`(syntax-parameterize (->*-internal (syntax/loc stx (->* . args)) #|method?|# #f)]))
((arrow:making-a-method #f))
#,(quasisyntax/loc stx
(->*-internal ->* . args)))]))
(define-syntax (->*-internal stx*) (define-for-syntax (->*-internal stx method?)
(define stx (syntax-case stx* () [(_ orig->* . args) (syntax/loc stx* (orig->* . args))]))
(define this->* (gensym 'this->*)) (define this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets (define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets opt-dom opt-dom-kwds opt-lets
@ -862,7 +850,6 @@
[(post-let-binding ...) (if (or post post/desc) [(post-let-binding ...) (if (or post post/desc)
(list #`[post-x (λ () #,(or post post/desc))]) (list #`[post-x (λ () #,(or post post/desc))])
(list))]) (list))])
(define method? (syntax-parameter-value #'arrow:making-a-method))
(define-values (plus-one-arity-function chaperone-constructor) (define-values (plus-one-arity-function chaperone-constructor)
(build-plus-one-arity-function+chaperone-constructor (build-plus-one-arity-function+chaperone-constructor
(syntax->list #'(mandatory-dom ...)) (syntax->list #'(mandatory-dom ...))
@ -881,27 +868,25 @@
optional-let-bindings ... optional-let-bindings ...
pre-let-binding ... pre-let-binding ...
post-let-binding ...) post-let-binding ...)
(syntax-parameterize (build--> '->*
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one (list mandatory-dom ...)
(build--> '->* (list optional-dom ...)
(list mandatory-dom ...) '(mandatory-dom-kwd ...)
(list optional-dom ...) (list mandatory-dom-kwd-ctc ...)
'(mandatory-dom-kwd ...) '(optional-dom-kwd ...)
(list mandatory-dom-kwd-ctc ...) (list optional-dom-kwd-ctc ...)
'(optional-dom-kwd ...) #,rest-ctc
(list optional-dom-kwd-ctc ...) #,(and pre #t)
#,rest-ctc #,(if rng-ctcs
#,(and pre #t) #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
#,(if rng-ctcs (syntax-property rng-ctc
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))]) 'racket/contract:positive-position
(syntax-property rng-ctc this->*)))
'racket/contract:positive-position #'#f)
this->*))) #,(and post #t)
#'#f) #,plus-one-arity-function
#,(and post #t) #,chaperone-constructor
#,plus-one-arity-function #,method?))
#,chaperone-constructor
#,method?)))
'racket/contract:contract 'racket/contract:contract
(vector this->* (vector this->*

79
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -11,7 +11,9 @@
"arrow-common.rkt" "arrow-common.rkt"
"arrow-val-first.rkt") "arrow-val-first.rkt")
(provide case->) (provide case->
(for-syntax case->-internal) ; for case->m
base-case->? case->-name) ; for object-contract
; ;
@ -48,7 +50,7 @@
[_ [_
(raise-syntax-error #f "expected ->" stx case)])) (raise-syntax-error #f "expected ->" stx case)]))
(define-for-syntax (parse-out-case stx neg-party blame-party-info case n) (define-for-syntax (parse-out-case stx neg-party blame-party-info case n method?)
(let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)]) (let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)])
(with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)] (with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)]
[(rst-proj-x) (generate-temporaries '(rest-proj-x))] [(rst-proj-x) (generate-temporaries '(rest-proj-x))]
@ -60,7 +62,9 @@
(generate-temporaries rng-ctc-exprs) (generate-temporaries rng-ctc-exprs)
'())] '())]
[(this-parameter ...) [(this-parameter ...)
(make-this-parameters (car (generate-temporaries '(this))))]) (if method?
(generate-temporaries '(this))
null)])
#`(#,dom-ctc-exprs #`(#,dom-ctc-exprs
#,rst-ctc-expr #,rst-ctc-expr
#,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f) #,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
@ -104,6 +108,11 @@
(dom-proj-x dom-formals neg-party) ...)])))))) (dom-proj-x dom-formals neg-party) ...)]))))))
(define-syntax (case-> stx) (define-syntax (case-> stx)
(syntax-case stx ()
[(_ . args)
(case->-internal (syntax/loc stx (case-> . args)) #|method?|# #f)]))
(define-for-syntax (case->-internal stx mctc?)
(syntax-case stx () (syntax-case stx ()
[(_ cases ...) [(_ cases ...)
(let () (let ()
@ -119,34 +128,31 @@
body) ...) body) ...)
(for/list ([x (in-list (syntax->list #'(cases ...)))] (for/list ([x (in-list (syntax->list #'(cases ...)))]
[n (in-naturals)]) [n (in-naturals)])
(parse-out-case stx #'neg-party #'blame-party-info x n))] (parse-out-case stx #'neg-party #'blame-party-info x n mctc?))])
[mctc? (and (syntax-parameter-value #'method-contract?) #t)]) #`(build-case->
#`(syntax-parameterize (list (list dom-ctc-expr ...) ...)
((making-a-method #f)) (list rst-ctc-expr ...)
(build-case-> (list rng-ctc-exprs ...)
(list (list dom-ctc-expr ...) ...) '(spec ...)
(list rst-ctc-expr ...) #,mctc?
(list rng-ctc-exprs ...) (λ (chk
'(spec ...) wrapper
mctc? blame
(λ (chk blame-party-info
wrapper ctc
blame rng-ctcs-x ...
blame-party-info #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
ctc #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
rng-ctcs-x ... (λ (f neg-party)
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) (define blame+neg-party (cons blame neg-party))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) (put-it-together
(λ (f neg-party) #,(let ([case-lam (syntax/loc stx
(define blame+neg-party (cons blame neg-party)) (case-lambda [formals body] ...))])
(put-it-together (if name
#,(let ([case-lam (syntax/loc stx #`(let ([#,name #,case-lam]) #,name)
(case-lambda [formals body] ...))]) case-lam))
(if name f blame neg-party blame+neg-party blame-party-info wrapper ctc
#`(let ([#,name #,case-lam]) #,name) chk #,mctc?))))))]))
case-lam))
f blame neg-party blame+neg-party blame-party-info wrapper ctc
chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
(define (put-it-together the-case-lam f blame neg-party blame+neg-party blame-party-info wrapper ctc chk mtd?) (define (put-it-together the-case-lam f blame neg-party blame+neg-party blame-party-info wrapper ctc chk mtd?)
(chk f mtd?) (chk f mtd?)
@ -183,7 +189,7 @@
;; rng-ctcs : (listof (listof contract)) ;; rng-ctcs : (listof (listof contract))
;; specs : (listof (list boolean exact-positive-integer)) ;; specs : (listof (list boolean exact-positive-integer))
;; indicates the required arities of the input functions ;; indicates the required arities of the input functions
;; mctc? : was created with case->m ;; mctc? : was created with case->m or object-contract
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) ;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?))
;; generates a wrapper from projections ;; generates a wrapper from projections
(define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper)) (define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))
@ -246,10 +252,11 @@
ctc ctc
projs)))) projs))))
(define (case->-name ctc) ;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt
(define ((case->-name print-as-method-if-method?) ctc)
(apply (apply
build-compound-type-name build-compound-type-name
(if (base-case->-mctc? ctc) 'case->m 'case->) (if (and (base-case->-mctc? ctc) print-as-method-if-method?) 'case->m 'case->)
(map (λ (dom rst range) (map (λ (dom rst range)
(apply (apply
build-compound-type-name build-compound-type-name
@ -277,7 +284,7 @@
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:late-neg-projection (case->-proj chaperone-procedure) #:late-neg-projection (case->-proj chaperone-procedure)
#:name case->-name #:name (case->-name #|print-as-method-if-method?|# #t)
#:first-order case->-first-order #:first-order case->-first-order
#:stronger case->-stronger?)) #:stronger case->-stronger?))
@ -286,7 +293,7 @@
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:late-neg-projection (case->-proj impersonate-procedure) #:late-neg-projection (case->-proj impersonate-procedure)
#:name case->-name #:name (case->-name #|print-as-method-if-method?|# #t)
#:first-order case->-first-order #:first-order case->-first-order
#:stronger case->-stronger?)) #:stronger case->-stronger?))

15
racket/collects/racket/contract/private/object.rkt
View File

@ -45,9 +45,10 @@
;; similar to `build-compound-type-name`, but handles method contract names ;; similar to `build-compound-type-name`, but handles method contract names
(define (object-contract-sub-name . fs) (define (object-contract-sub-name . fs)
(for/list ([sub (in-list fs)]) (for/list ([sub (in-list fs)])
(cond [(base->? sub) ((base->-name #|print-as-method-if-method?|# #f) sub)] ; covers -> and ->* (cond [(base->? sub) ((base->-name #|print-as-method-if-method?|# #f) sub)] ; covers -> and ->*
[(base-->d? sub) ((->d-name #|print-as-method-if-method?|# #f) sub)] [(base-->d? sub) ((->d-name #|print-as-method-if-method?|# #f) sub)]
;; `->i` and `case->` will naturally print correctly, due to the way they handle methods [(base-case->? sub) ((case->-name #|print-as-method-if-method?|# #f) sub)]
;; `->i` will naturally print correctly, due to the way it handles methods
[(contract-struct? sub) (contract-struct-name sub)] [(contract-struct? sub) (contract-struct-name sub)]
[else sub]))) [else sub])))
@ -88,9 +89,7 @@
(map (λ (x) (string->symbol (format "~a method" (syntax-e x)))) (map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
(syntax->list #'(method-id ...)))]) (syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...) #'(build-object-contract '(method-id ...)
(syntax-parameterize (list (let ([method-name (fun->meth method-ctc)]) method-name) ...)
((making-a-method #t))
(list (let ([method-name (fun->meth method-ctc)]) method-name) ...))
'(field-id ...) '(field-id ...)
(list field-ctc ...))))])) (list field-ctc ...))))]))
(define-syntax (fun->meth stx) (define-syntax (fun->meth stx)
@ -100,8 +99,8 @@
[(-> . args) #'(->m . args)] [(-> . args) #'(->m . args)]
[(->* . args) #'(->*m . args)] [(->* . args) #'(->*m . args)]
[(->d . args) #'(->dm . args)] [(->d . args) #'(->dm . args)]
[(->i . args) #'ctc] ; ->i doesn't reset the `making-a-method` syntax parameter [(case-> case ...) #'(case->m case ...)]
[(case-> case ...) #'ctc])])) ; neither does case-> [(->i . args) (->i-internal #'ctc #|method?|# #t)])])) ; there's no ->im. could be, though, code is there
(define (build-object-contract methods method-ctcs fields field-ctcs) (define (build-object-contract methods method-ctcs fields field-ctcs)
(make-object-contract methods (make-object-contract methods

33
racket/collects/racket/private/class-c-old.rkt
View File

@ -8,8 +8,9 @@
"class-internal.rkt" "class-internal.rkt"
"../contract/base.rkt" "../contract/base.rkt"
"../contract/combinator.rkt" "../contract/combinator.rkt"
(only-in "../contract/private/arrow-common.rkt" making-a-method method-contract?) (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)
(only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal)) (only-in "../contract/private/case-arrow.rkt" case->-internal)
(only-in "../contract/private/arr-d.rkt" ->d-internal))
(provide make-class/c class/c-late-neg-proj (provide make-class/c class/c-late-neg-proj
blame-add-method-context blame-add-field-context blame-add-init-context blame-add-method-context blame-add-field-context blame-add-init-context
@ -25,17 +26,29 @@
;; Shorthand contracts that treat the implicit object argument as if it were ;; Shorthand contracts that treat the implicit object argument as if it were
;; contracted with any/c. ;; contracted with any/c.
(define-syntax-rule (->m . stx) (define-syntax (->m stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->-internal ->m . stx))) (syntax-case stx ()
[(_ . args)
(->-internal (syntax/loc stx (->m . args))
#|method?|# #t)]))
(define-syntax-rule (->*m . stx) (define-syntax (->*m stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*-internal ->*m . stx))) (syntax-case stx ()
[(_ . args)
(->*-internal (syntax/loc stx (->*m . args))
#|method?|# #t)]))
(define-syntax-rule (case->m . stx) (define-syntax (case->m stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx))) (syntax-case stx ()
[(_ . args)
(case->-internal (syntax/loc stx (case->m . args))
#|method?|# #t)]))
(define-syntax-rule (->dm . stx) (define-syntax (->dm stx)
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx))) (syntax-case stx ()
[(_ . args)
(->d-internal (syntax/loc stx (->dm . args))
#|maybe-this-param|# #'#'this-param)]))
(define (class/c-check-first-order ctc cls fail) (define (class/c-check-first-order ctc cls fail)
(define opaque? (class/c-opaque? ctc)) (define opaque? (class/c-opaque? ctc))