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

->2 -> ->

Browse Source
This commit is contained in:
Vincent St-Amour 2016-03-30 10:49:09 -05:00
parent 62aa2b75bf
commit 077e6da2cb
8 changed files with 40 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/collects/racket/contract/base.rkt
View File

@ -44,7 +44,7 @@
blame-add-range-context blame-add-range-context
blame-add-nth-arg-context blame-add-nth-arg-context
(rename-out [->2 ->] [->*2 ->*]) -> ->*
dynamic->* dynamic->*
predicate/c predicate/c
@ -154,5 +154,5 @@
;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise ;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise
;; the argument is simply the value to return. ;; the argument is simply the value to return.
(define failure-result/c (define failure-result/c
(if/c procedure? (->2 any) any/c)) (if/c procedure? (-> any) any/c))

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

@ -13,24 +13,24 @@
racket/stxparam racket/stxparam
(prefix-in arrow: "arrow-common.rkt")) (prefix-in arrow: "arrow-common.rkt"))
(provide ->2 ->*2 (provide (rename-out [->/c ->]) ->*
->2-internal ->*2-internal ; for ->m and ->*m ->-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
(for-syntax parse-leftover->*) (for-syntax parse-leftover->*)
(for-syntax ->2-arity-check-only->? (for-syntax ->-arity-check-only->?
->2*-arity-check-only->? ->*-arity-check-only->?
->-valid-app-shapes ->-valid-app-shapes
->*-valid-app-shapes) ->*-valid-app-shapes)
(rename-out [-predicate/c predicate/c])) (rename-out [-predicate/c predicate/c]))
(define-for-syntax (->2-arity-check-only->? stx) (define-for-syntax (->-arity-check-only->? stx)
(syntax-case stx (any any/c) (syntax-case stx (any any/c)
[(_ any/c ... any) (- (length (syntax->list stx)) 2)] [(_ any/c ... any) (- (length (syntax->list stx)) 2)]
[_ #f])) [_ #f]))
(define-for-syntax (->2*-arity-check-only->? stx) (define-for-syntax (->*-arity-check-only->? stx)
(syntax-case stx (any any/c) (syntax-case stx (any any/c)
[(_ (any/c ...) any) (length (syntax->list (cadr (syntax->list stx))))] [(_ (any/c ...) any) (length (syntax->list (cadr (syntax->list stx))))]
[(_ (any/c ...) () any) (length (syntax->list (cadr (syntax->list stx))))] [(_ (any/c ...) () any) (length (syntax->list (cadr (syntax->list stx))))]
@ -641,16 +641,16 @@
(map syntax->datum kwds) (map syntax->datum kwds)
'()))])) '()))]))
(define-syntax (->2 stx) (define-syntax (->/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ . args)
(let () (let ()
#`(syntax-parameterize #`(syntax-parameterize
((arrow:making-a-method #f)) ((arrow:making-a-method #f))
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(->2-internal -> . args))))])) (->-internal -> . args))))]))
(define-syntax (->2-internal stx*) (define-syntax (->-internal stx*)
(syntax-case stx* () (syntax-case stx* ()
[(_ orig-> args ... rng) [(_ orig-> args ... rng)
(let () (let ()
@ -739,7 +739,7 @@
this->*)] this->*)]
let-bindings)))]))) let-bindings)))])))
(define-for-syntax (parse->*2 stx this->*) (define-for-syntax (parse->* stx this->*)
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-dom ...) . other) [(_ (raw-mandatory-dom ...) . other)
(let () (let ()
@ -823,7 +823,7 @@
(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
rest-ctc pre pre/desc rng-ctcs post post/desc) rest-ctc pre pre/desc rng-ctcs post post/desc)
(parse->*2 stx this->*)) (parse->* stx this->*))
(with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] (with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]) [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
(valid-app-shapes-from-man/opts (length (syntax->list man-dom)) (valid-app-shapes-from-man/opts (length (syntax->list man-dom))
@ -832,21 +832,21 @@
(syntax->datum #'(mandatory-dom-kwd ...)) (syntax->datum #'(mandatory-dom-kwd ...))
(syntax->datum #'(optional-dom-kwd ...))))) (syntax->datum #'(optional-dom-kwd ...)))))
(define-syntax (->*2 stx) (define-syntax (->* stx)
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ . args)
#`(syntax-parameterize #`(syntax-parameterize
((arrow:making-a-method #f)) ((arrow:making-a-method #f))
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(->*2-internal ->* . args)))])) (->*-internal ->* . args)))]))
(define-syntax (->*2-internal stx*) (define-syntax (->*-internal stx*)
(define stx (syntax-case stx* () [(_ orig->* . args) (syntax/loc stx* (orig->* . args))])) (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
rest-ctc pre pre/desc rng-ctcs post post/desc) rest-ctc pre pre/desc rng-ctcs post post/desc)
(parse->*2 stx this->*)) (parse->* stx this->*))
(with-syntax ([(mandatory-dom ...) man-dom] (with-syntax ([(mandatory-dom ...) man-dom]
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] [((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
[(mandatory-let-bindings ...) man-lets] [(mandatory-let-bindings ...) man-lets]

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

@ -38,15 +38,11 @@
[x #'(x)])) [x #'(x)]))
(define-for-syntax (separate-out-doms/rst/rng stx case) (define-for-syntax (separate-out-doms/rst/rng stx case)
(syntax-case case (-> ->2) (syntax-case case (->)
[(-> doms ... #:rest rst rng) [(-> doms ... #:rest rst rng)
(values #'(doms ...) #'rst (parse-rng stx #'rng))] (values #'(doms ...) #'rst (parse-rng stx #'rng))]
[(->2 doms ... #:rest rst rng)
(values #'(doms ...) #'rst (parse-rng stx #'rng))]
[(-> doms ... rng) [(-> doms ... rng)
(values #'(doms ...) #f (parse-rng stx #'rng))] (values #'(doms ...) #f (parse-rng stx #'rng))]
[(->2 doms ... rng)
(values #'(doms ...) #f (parse-rng stx #'rng))]
[(x y ...) [(x y ...)
(raise-syntax-error #f "expected ->" stx #'x)] (raise-syntax-error #f "expected ->" stx #'x)]
[_ [_

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

@ -96,11 +96,11 @@
(define-syntax (fun->meth stx) (define-syntax (fun->meth stx)
(syntax-case stx () (syntax-case stx ()
[(_ ctc) [(_ ctc)
(syntax-case #'ctc (->2 ->*2 ->d ->i case->) (syntax-case #'ctc (-> ->* ->d ->i case->)
[(->2 . args) #'(->m . args)] [(-> . args) #'(->m . args)]
[(->*2 . 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 [(->i . args) #'ctc] ; ->i doesn't reset the `making-a-method` syntax parameter
[(case-> case ...) #'ctc])])) ; neither does case-> [(case-> case ...) #'ctc])])) ; neither does case->
(define (build-object-contract methods method-ctcs fields field-ctcs) (define (build-object-contract methods method-ctcs fields field-ctcs)

1
racket/collects/racket/contract/private/opters.rkt
View File

@ -728,7 +728,6 @@
(opt/unknown opt/i opt/info stx))))])) (opt/unknown opt/i opt/info stx))))]))
(define/opter (-> opt/i opt/info stx) (->-opter opt/i opt/info stx)) (define/opter (-> opt/i opt/info stx) (->-opter opt/i opt/info stx))
(define/opter (->2 opt/i opt/info stx) (->-opter opt/i opt/info stx))
(define opt->/c-cm-key (gensym 'opt->/c-cm-key)) (define opt->/c-cm-key (gensym 'opt->/c-cm-key))

22
racket/collects/racket/contract/private/provide.rkt
View File

@ -279,12 +279,12 @@
contract-error-name contract-error-name
pos-module-source) pos-module-source)
(define-values (arrow? the-valid-app-shapes) (define-values (arrow? the-valid-app-shapes)
(syntax-case ctrct (->2 ->*2 ->i) (syntax-case ctrct (-> ->* ->i)
[(->2 . _) [(-> . _)
(not (->2-arity-check-only->? ctrct)) (not (->-arity-check-only->? ctrct))
(values #t (->-valid-app-shapes ctrct))] (values #t (->-valid-app-shapes ctrct))]
[(->*2 . _) [(->* . _)
(values (not (->2*-arity-check-only->? ctrct)) (values (not (->*-arity-check-only->? ctrct))
(->*-valid-app-shapes ctrct))] (->*-valid-app-shapes ctrct))]
[(->i . _) (values #t (->i-valid-app-shapes ctrct))] [(->i . _) (values #t (->i-valid-app-shapes ctrct))]
[_ (values #f #f)])) [_ (values #f #f)]))
@ -990,24 +990,24 @@
(with-syntax ([(field-contract-ids ...) field-contract-ids] (with-syntax ([(field-contract-ids ...) field-contract-ids]
[predicate-id predicate-id]) [predicate-id predicate-id])
(syntax/loc stx (syntax/loc stx
(->2 field-contract-ids ... (-> field-contract-ids ...
predicate-id)))) predicate-id))))
;; build-selector-contract : syntax syntax -> syntax ;; build-selector-contract : syntax syntax -> syntax
;; constructs the contract for a selector ;; constructs the contract for a selector
(define (build-selector-contract struct-name predicate-id field-contract-id) (define (build-selector-contract struct-name predicate-id field-contract-id)
(with-syntax ([field-contract-id field-contract-id] (with-syntax ([field-contract-id field-contract-id]
[predicate-id predicate-id]) [predicate-id predicate-id])
(syntax (->2 predicate-id field-contract-id)))) (syntax (-> predicate-id field-contract-id))))
;; build-mutator-contract : syntax syntax -> syntax ;; build-mutator-contract : syntax syntax -> syntax
;; constructs the contract for a selector ;; constructs the contract for a selector
(define (build-mutator-contract struct-name predicate-id field-contract-id) (define (build-mutator-contract struct-name predicate-id field-contract-id)
(with-syntax ([field-contract-id field-contract-id] (with-syntax ([field-contract-id field-contract-id]
[predicate-id predicate-id]) [predicate-id predicate-id])
(syntax (->2 predicate-id (syntax (-> predicate-id
field-contract-id field-contract-id
void?)))) void?))))
;; code-for-one-poly-id : syntax -> syntax ;; code-for-one-poly-id : syntax -> syntax
(define (code-for-one-poly-id x x-gen poly) (define (code-for-one-poly-id x x-gen poly)

6
racket/collects/racket/contract/region.rkt
View File

@ -174,11 +174,11 @@
(for/list ([finfo field-infos]) (for/list ([finfo field-infos])
(let ([field-ctc (field-info-ctc finfo)]) (let ([field-ctc (field-info-ctc finfo)])
(cons (quasisyntax/loc stx (cons (quasisyntax/loc stx
(->2 #,pred #,field-ctc)) (-> #,pred #,field-ctc))
(if (field-info-mutable? finfo) (if (field-info-mutable? finfo)
(list (list
(quasisyntax/loc stx (quasisyntax/loc stx
(->2 #,pred #,field-ctc void?))) (-> #,pred #,field-ctc void?)))
null))))))) null)))))))
(define (check-field f ctc) (define (check-field f ctc)
@ -434,7 +434,7 @@
(define-struct/derived orig name (field ...) (define-struct/derived orig name (field ...)
omit-stx-def ... omit-stx-def ...
kwds ... kwds ...
#:guard (contract (->2 super-contract ... non-auto-contracts ... symbol? any) #:guard (contract (-> super-contract ... non-auto-contracts ... symbol? any)
guard guard
(current-contract-region) blame-id (current-contract-region) blame-id
(quote maker) (quote maker)

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

@ -9,7 +9,7 @@
"../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-common.rkt" making-a-method method-contract?)
(only-in "../contract/private/arrow-val-first.rkt" ->2-internal ->*2-internal)) (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-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
@ -26,10 +26,10 @@
;; 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-rule (->m . stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->2-internal ->m . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->-internal ->m . stx)))
(define-syntax-rule (->*m . stx) (define-syntax-rule (->*m . stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*2-internal ->*m . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*-internal ->*m . stx)))
(define-syntax-rule (case->m . stx) (define-syntax-rule (case->m . stx)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))