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-nth-arg-context
(rename-out [->2 ->] [->*2 ->*])
-> ->*
dynamic->*
predicate/c
@ -154,5 +154,5 @@
;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise
;; the argument is simply the value to return.
(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
(prefix-in arrow: "arrow-common.rkt"))
(provide ->2 ->*2
->2-internal ->*2-internal ; for ->m and ->*m
(provide (rename-out [->/c ->]) ->*
->-internal ->*-internal ; for ->m and ->*m
base->? base->-name base->-rngs base->-doms
dynamic->*
arity-checking-wrapper
(for-syntax parse-leftover->*)
(for-syntax ->2-arity-check-only->?
->2*-arity-check-only->?
(for-syntax ->-arity-check-only->?
->*-arity-check-only->?
->-valid-app-shapes
->*-valid-app-shapes)
(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)
[(_ any/c ... any) (- (length (syntax->list stx)) 2)]
[_ #f]))
(define-for-syntax (->2*-arity-check-only->? stx)
(define-for-syntax (->*-arity-check-only->? stx)
(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))))]
@ -641,16 +641,16 @@
(map syntax->datum kwds)
'()))]))
(define-syntax (->2 stx)
(define-syntax (->/c stx)
(syntax-case stx ()
[(_ . args)
(let ()
#`(syntax-parameterize
((arrow:making-a-method #f))
#,(quasisyntax/loc stx
(->2-internal -> . args))))]))
(->-internal -> . args))))]))
(define-syntax (->2-internal stx*)
(define-syntax (->-internal stx*)
(syntax-case stx* ()
[(_ orig-> args ... rng)
(let ()
@ -739,7 +739,7 @@
this->*)]
let-bindings)))])))
(define-for-syntax (parse->*2 stx this->*)
(define-for-syntax (parse->* stx this->*)
(syntax-case stx ()
[(_ (raw-mandatory-dom ...) . other)
(let ()
@ -823,7 +823,7 @@
(define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets
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]
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds])
(valid-app-shapes-from-man/opts (length (syntax->list man-dom))
@ -832,21 +832,21 @@
(syntax->datum #'(mandatory-dom-kwd ...))
(syntax->datum #'(optional-dom-kwd ...)))))
(define-syntax (->*2 stx)
(define-syntax (->* stx)
(syntax-case stx ()
[(_ . args)
#`(syntax-parameterize
((arrow:making-a-method #f))
#,(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 this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets
opt-dom opt-dom-kwds opt-lets
rest-ctc pre pre/desc rng-ctcs post post/desc)
(parse->*2 stx this->*))
(parse->* stx this->*))
(with-syntax ([(mandatory-dom ...) man-dom]
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
[(mandatory-let-bindings ...) man-lets]

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

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

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

@ -96,9 +96,9 @@
(define-syntax (fun->meth stx)
(syntax-case stx ()
[(_ ctc)
(syntax-case #'ctc (->2 ->*2 ->d ->i case->)
[(->2 . args) #'(->m . args)]
[(->*2 . args) #'(->*m . args)]
(syntax-case #'ctc (-> ->* ->d ->i case->)
[(-> . 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->

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

@ -728,7 +728,6 @@
(opt/unknown 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))

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

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

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

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

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

@ -9,7 +9,7 @@
"../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" ->2-internal ->*2-internal))
(only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal))
(provide make-class/c class/c-late-neg-proj
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
;; contracted with any/c.
(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)
(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)
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))