Don't use syntax parameters for method contracts.
Can be done with plain old functions.
This commit is contained in:
Vincent St-Amour
parent
0aec872710
commit
209f2db611
|
|
@ -12,6 +12,7 @@
|
|||
"arrow-common.rkt")
|
||||
|
||||
(provide ->d
|
||||
(for-syntax ->d-internal) ; for ->dm
|
||||
base-->d? ->d-name) ; for object-contract
|
||||
|
||||
;
|
||||
|
|
@ -132,6 +133,11 @@
|
|||
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
|
||||
|
||||
(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 ()
|
||||
[(_ (raw-mandatory-doms ...)
|
||||
.
|
||||
|
|
@ -148,9 +154,9 @@
|
|||
#'((optional-kwd optional-kwd-id) ...
|
||||
(mandatory-kwd mandatory-kwd-id) ...)))]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
|
||||
(car (generate-temporaries '(this)))
|
||||
(datum->syntax stx 'this #f)))])
|
||||
(if maybe-this-param
|
||||
(generate-temporaries '(this))
|
||||
null)])
|
||||
(with-syntax ([(dom-params ...)
|
||||
#`(this-parameter ...
|
||||
mandatory-regular-id ...
|
||||
|
|
@ -167,8 +173,7 @@
|
|||
[any #'(() #f)]
|
||||
[[id ctc] #'((id) (ctc))]
|
||||
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
|
||||
[mtd? (and (syntax-parameter-value #'making-a-method) #t)]
|
||||
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)])
|
||||
[mtd? (and maybe-this-param #t)])
|
||||
(let ([rng-underscores?
|
||||
(let ([is-underscore?
|
||||
(λ (x)
|
||||
|
|
@ -195,7 +200,7 @@
|
|||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(let-syntax ([parameterize-this
|
||||
(let ([old-param (syntax-parameter-value #'making-a-method)])
|
||||
(let ([old-param #,maybe-this-param])
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body) #'body]
|
||||
|
|
@ -207,44 +212,42 @@
|
|||
([param (make-this-transformer #'id)])
|
||||
body)))
|
||||
#'body)])))])
|
||||
(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
(build-->d mtd? ->m-ctc?
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-doms)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-doms)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... rst-ctc)))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... #,pre-cond))
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... #,post-cond))
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args)))))))))))))]))
|
||||
(build-->d mtd?
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-doms)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-doms)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... rst-ctc)))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... #,pre-cond))
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... #,post-cond))
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args))))))))))))]))
|
||||
|
||||
(define ((late-neg-->d-proj wrap-procedure) ->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 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-kwd-dom-ctcs optional-kwd-dom-ctcs
|
||||
rest-ctc pre-cond range post-cond
|
||||
|
|
@ -473,7 +476,7 @@
|
|||
(append mandatory-kwds optional-kwds)
|
||||
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
|
||||
(λ (x y) (keyword<? (car x) (car y))))])
|
||||
(make-impersonator-->d mtd? mctc?
|
||||
(make-impersonator-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
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
|
||||
(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]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
|
|
@ -550,7 +553,6 @@
|
|||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(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))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
|
|
|
|||
|
|
@ -25,7 +25,8 @@
|
|||
[module-identifier-mapping-put! free-identifier-mapping-put!]
|
||||
[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 arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x)))
|
||||
|
|
@ -841,7 +842,7 @@ evaluted left-to-right.)
|
|||
body))]
|
||||
[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
|
||||
blame-ids args+rst
|
||||
|
|
@ -864,8 +865,7 @@ evaluted left-to-right.)
|
|||
(generate-temporaries (map arg/res-var ordered-ress)))
|
||||
|
||||
|
||||
(define this-param (and (syntax-parameter-value #'making-a-method)
|
||||
(car (generate-temporaries '(this)))))
|
||||
(define this-param (and method? (car (generate-temporaries '(this)))))
|
||||
|
||||
(define wrapper-body
|
||||
(add-wrapper-let
|
||||
|
|
@ -899,7 +899,7 @@ evaluted left-to-right.)
|
|||
#`(λ #,wrapper-proc-arglist
|
||||
(λ (val 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
|
||||
val
|
||||
(let ([arg-checker
|
||||
|
|
@ -1026,7 +1026,7 @@ evaluted left-to-right.)
|
|||
arg-proj-vars indy-arg-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
|
||||
blame-ids args+rst
|
||||
ordered-args arg-indices
|
||||
|
|
@ -1048,8 +1048,7 @@ evaluted left-to-right.)
|
|||
(generate-temporaries (map arg/res-var ordered-ress)))
|
||||
|
||||
|
||||
(define this-param (and (syntax-parameter-value #'making-a-method)
|
||||
(car (generate-temporaries '(this)))))
|
||||
(define this-param (and method? (car (generate-temporaries '(this)))))
|
||||
|
||||
#`(λ #,wrapper-proc-arglist
|
||||
(λ (f)
|
||||
|
|
@ -1138,10 +1137,15 @@ evaluted left-to-right.)
|
|||
vars))
|
||||
|
||||
(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 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 val-first-wrapper-func (mk-val-first-wrapper-func/blame-id-info 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 method?))
|
||||
(define args+rst (append (istx-args an-istx)
|
||||
(if (istx-rst an-istx)
|
||||
(list (istx-rst an-istx))
|
||||
|
|
@ -1311,7 +1315,7 @@ evaluted left-to-right.)
|
|||
(istx-args an-istx)))
|
||||
keyword<?)
|
||||
'#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx)))
|
||||
#,(and (syntax-parameter-value #'making-a-method) #t)
|
||||
#,method?
|
||||
(quote-module-name)
|
||||
#,wrapper-func
|
||||
#,val-first-wrapper-func
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
racket/stxparam)
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide making-a-method method-contract? (for-syntax make-this-parameters)
|
||||
blame-add-range-context
|
||||
(provide blame-add-range-context
|
||||
blame-add-nth-arg-context
|
||||
check-procedure check-procedure/more
|
||||
procedure-accepts-and-more?
|
||||
|
|
@ -27,13 +26,6 @@
|
|||
(define-struct 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)
|
||||
(blame-add-context blame "the range of"))
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(prefix-in arrow: "arrow-common.rkt"))
|
||||
|
||||
(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
|
||||
dynamic->*
|
||||
arity-checking-wrapper
|
||||
|
|
@ -644,17 +644,12 @@
|
|||
(define-syntax (->/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(let ()
|
||||
#`(syntax-parameterize
|
||||
((arrow:making-a-method #f))
|
||||
#,(quasisyntax/loc stx
|
||||
(->-internal -> . args))))]))
|
||||
(->-internal (syntax/loc stx (-> . args)) #|method?|# #f)]))
|
||||
|
||||
(define-syntax (->-internal stx*)
|
||||
(syntax-case stx* ()
|
||||
[(_ orig-> args ... rng)
|
||||
(define-for-syntax (->-internal stx method?)
|
||||
(syntax-case stx ()
|
||||
[(_ args ... rng)
|
||||
(let ()
|
||||
(define stx (syntax/loc stx* (orig-> args ... rng)))
|
||||
(define this-> (gensym 'this->))
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
|
||||
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
|
||||
|
|
@ -666,29 +661,26 @@
|
|||
[any #f]
|
||||
[(values rng ...) (add-pos-obligations (syntax->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)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f
|
||||
method?))
|
||||
(syntax-property
|
||||
#`(syntax-parameterize
|
||||
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
|
||||
(let #,let-bindings
|
||||
#,(quasisyntax/loc stx
|
||||
(build-simple-->
|
||||
(list #,@regular-args)
|
||||
'(#,@kwds)
|
||||
(list #,@kwd-args)
|
||||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,(if ellipsis-info
|
||||
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
|
||||
#'#f)
|
||||
#,method?))))
|
||||
#`(let #,let-bindings
|
||||
#,(quasisyntax/loc stx
|
||||
(build-simple-->
|
||||
(list #,@regular-args)
|
||||
'(#,@kwds)
|
||||
(list #,@kwd-args)
|
||||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,(if ellipsis-info
|
||||
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
|
||||
#'#f)
|
||||
#,method?)))
|
||||
'racket/contract:contract
|
||||
(vector this->
|
||||
;; the -> in the original input to this guy
|
||||
|
|
@ -835,13 +827,9 @@
|
|||
(define-syntax (->* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
#`(syntax-parameterize
|
||||
((arrow:making-a-method #f))
|
||||
#,(quasisyntax/loc stx
|
||||
(->*-internal ->* . args)))]))
|
||||
(->*-internal (syntax/loc stx (->* . args)) #|method?|# #f)]))
|
||||
|
||||
(define-syntax (->*-internal stx*)
|
||||
(define stx (syntax-case stx* () [(_ orig->* . args) (syntax/loc stx* (orig->* . args))]))
|
||||
(define-for-syntax (->*-internal stx method?)
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
|
|
@ -862,7 +850,6 @@
|
|||
[(post-let-binding ...) (if (or post post/desc)
|
||||
(list #`[post-x (λ () #,(or post post/desc))])
|
||||
(list))])
|
||||
(define method? (syntax-parameter-value #'arrow:making-a-method))
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
(syntax->list #'(mandatory-dom ...))
|
||||
|
|
@ -881,27 +868,25 @@
|
|||
optional-let-bindings ...
|
||||
pre-let-binding ...
|
||||
post-let-binding ...)
|
||||
(syntax-parameterize
|
||||
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
|
||||
(build--> '->*
|
||||
(list mandatory-dom ...)
|
||||
(list optional-dom ...)
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(and pre #t)
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(and post #t)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,method?)))
|
||||
(build--> '->*
|
||||
(list mandatory-dom ...)
|
||||
(list optional-dom ...)
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(and pre #t)
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(and post #t)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,method?))
|
||||
|
||||
'racket/contract:contract
|
||||
(vector this->*
|
||||
|
|
|
|||
|
|
@ -11,7 +11,9 @@
|
|||
"arrow-common.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)]))
|
||||
|
||||
(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)])
|
||||
(with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)]
|
||||
[(rst-proj-x) (generate-temporaries '(rest-proj-x))]
|
||||
|
|
@ -60,7 +62,9 @@
|
|||
(generate-temporaries rng-ctc-exprs)
|
||||
'())]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (car (generate-temporaries '(this))))])
|
||||
(if method?
|
||||
(generate-temporaries '(this))
|
||||
null)])
|
||||
#`(#,dom-ctc-exprs
|
||||
#,rst-ctc-expr
|
||||
#,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
|
||||
|
|
@ -104,6 +108,11 @@
|
|||
(dom-proj-x dom-formals neg-party) ...)]))))))
|
||||
|
||||
(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 ()
|
||||
[(_ cases ...)
|
||||
(let ()
|
||||
|
|
@ -119,34 +128,31 @@
|
|||
body) ...)
|
||||
(for/list ([x (in-list (syntax->list #'(cases ...)))]
|
||||
[n (in-naturals)])
|
||||
(parse-out-case stx #'neg-party #'blame-party-info x n))]
|
||||
[mctc? (and (syntax-parameter-value #'method-contract?) #t)])
|
||||
#`(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
(build-case->
|
||||
(list (list dom-ctc-expr ...) ...)
|
||||
(list rst-ctc-expr ...)
|
||||
(list rng-ctc-exprs ...)
|
||||
'(spec ...)
|
||||
mctc?
|
||||
(λ (chk
|
||||
wrapper
|
||||
blame
|
||||
blame-party-info
|
||||
ctc
|
||||
rng-ctcs-x ...
|
||||
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
|
||||
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
|
||||
(λ (f neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(put-it-together
|
||||
#,(let ([case-lam (syntax/loc stx
|
||||
(case-lambda [formals body] ...))])
|
||||
(if name
|
||||
#`(let ([#,name #,case-lam]) #,name)
|
||||
case-lam))
|
||||
f blame neg-party blame+neg-party blame-party-info wrapper ctc
|
||||
chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))]))
|
||||
(parse-out-case stx #'neg-party #'blame-party-info x n mctc?))])
|
||||
#`(build-case->
|
||||
(list (list dom-ctc-expr ...) ...)
|
||||
(list rst-ctc-expr ...)
|
||||
(list rng-ctc-exprs ...)
|
||||
'(spec ...)
|
||||
#,mctc?
|
||||
(λ (chk
|
||||
wrapper
|
||||
blame
|
||||
blame-party-info
|
||||
ctc
|
||||
rng-ctcs-x ...
|
||||
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
|
||||
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
|
||||
(λ (f neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(put-it-together
|
||||
#,(let ([case-lam (syntax/loc stx
|
||||
(case-lambda [formals body] ...))])
|
||||
(if name
|
||||
#`(let ([#,name #,case-lam]) #,name)
|
||||
case-lam))
|
||||
f blame neg-party blame+neg-party blame-party-info wrapper ctc
|
||||
chk #,mctc?))))))]))
|
||||
|
||||
(define (put-it-together the-case-lam f blame neg-party blame+neg-party blame-party-info wrapper ctc chk mtd?)
|
||||
(chk f mtd?)
|
||||
|
|
@ -183,7 +189,7 @@
|
|||
;; rng-ctcs : (listof (listof contract))
|
||||
;; specs : (listof (list boolean exact-positive-integer))
|
||||
;; 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?))
|
||||
;; generates a wrapper from projections
|
||||
(define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))
|
||||
|
|
@ -246,10 +252,11 @@
|
|||
ctc
|
||||
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
|
||||
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)
|
||||
(apply
|
||||
build-compound-type-name
|
||||
|
|
@ -277,7 +284,7 @@
|
|||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:late-neg-projection (case->-proj chaperone-procedure)
|
||||
#:name case->-name
|
||||
#:name (case->-name #|print-as-method-if-method?|# #t)
|
||||
#:first-order case->-first-order
|
||||
#:stronger case->-stronger?))
|
||||
|
||||
|
|
@ -286,7 +293,7 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (case->-proj impersonate-procedure)
|
||||
#:name case->-name
|
||||
#:name (case->-name #|print-as-method-if-method?|# #t)
|
||||
#:first-order case->-first-order
|
||||
#:stronger case->-stronger?))
|
||||
|
||||
|
|
|
|||
|
|
@ -45,9 +45,10 @@
|
|||
;; similar to `build-compound-type-name`, but handles method contract names
|
||||
(define (object-contract-sub-name . fs)
|
||||
(for/list ([sub (in-list fs)])
|
||||
(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)]
|
||||
;; `->i` and `case->` will naturally print correctly, due to the way they handle methods
|
||||
(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-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)]
|
||||
[else sub])))
|
||||
|
||||
|
|
@ -88,9 +89,7 @@
|
|||
(map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
|
||||
(syntax->list #'(method-id ...)))])
|
||||
#'(build-object-contract '(method-id ...)
|
||||
(syntax-parameterize
|
||||
((making-a-method #t))
|
||||
(list (let ([method-name (fun->meth method-ctc)]) method-name) ...))
|
||||
(list (let ([method-name (fun->meth method-ctc)]) method-name) ...)
|
||||
'(field-id ...)
|
||||
(list field-ctc ...))))]))
|
||||
(define-syntax (fun->meth stx)
|
||||
|
|
@ -100,8 +99,8 @@
|
|||
[(-> . args) #'(->m . args)]
|
||||
[(->* . args) #'(->*m . args)]
|
||||
[(->d . args) #'(->dm . args)]
|
||||
[(->i . args) #'ctc] ; ->i doesn't reset the `making-a-method` syntax parameter
|
||||
[(case-> case ...) #'ctc])])) ; neither does case->
|
||||
[(case-> case ...) #'(case->m 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)
|
||||
(make-object-contract methods
|
||||
|
|
|
|||
|
|
@ -8,8 +8,9 @@
|
|||
"class-internal.rkt"
|
||||
"../contract/base.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
|
||||
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
|
||||
;; contracted with any/c.
|
||||
(define-syntax-rule (->m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->-internal ->m . stx)))
|
||||
(define-syntax (->m stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(->-internal (syntax/loc stx (->m . args))
|
||||
#|method?|# #t)]))
|
||||
|
||||
(define-syntax-rule (->*m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*-internal ->*m . stx)))
|
||||
(define-syntax (->*m stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(->*-internal (syntax/loc stx (->*m . args))
|
||||
#|method?|# #t)]))
|
||||
|
||||
(define-syntax-rule (case->m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))
|
||||
(define-syntax (case->m stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
(case->-internal (syntax/loc stx (case->m . args))
|
||||
#|method?|# #t)]))
|
||||
|
||||
(define-syntax-rule (->dm . stx)
|
||||
(syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
|
||||
(define-syntax (->dm 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 opaque? (class/c-opaque? ctc))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user