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

add obligation properties to ->*

Browse Source 
for online check syntax to pick up
This commit is contained in:
Robby Findler 2014-11-27 16:41:33 -06:00
parent 9ee9f6767d
commit 0e22209a81
1 changed files with 45 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -498,7 +498,7 @@
'())))])) '())))]))
;; not quite the same as split-doms in arr-util.rkt, but similar idea. ;; not quite the same as split-doms in arr-util.rkt, but similar idea.
(define-for-syntax (:split-doms stx name raw-doms) (define-for-syntax (:split-doms stx name raw-doms this->*)
(let loop ([raw-doms raw-doms] (let loop ([raw-doms raw-doms]
[doms '()] [doms '()]
[kwd-doms '()] [kwd-doms '()]
@ -514,7 +514,10 @@
(loop #'rest (loop #'rest
doms doms
(cons #'(kwd x) kwd-doms) (cons #'(kwd x) kwd-doms)
(cons #`[x arg] let-bindings)))] (cons #`[x #,(syntax-property #'arg
'racket/contract:negative-position
this->*)]
let-bindings)))]
[(kwd arg . rest) [(kwd arg . rest)
(and (keyword? (syntax-e #'kwd)) (and (keyword? (syntax-e #'kwd))
(keyword? (syntax-e #'arg))) (keyword? (syntax-e #'arg)))
@ -533,9 +536,12 @@
(loop #'rest (loop #'rest
(cons #'t doms) (cons #'t doms)
kwd-doms kwd-doms
(cons #`[t x] let-bindings)))]))) (cons #`[t #,(syntax-property #'x
'racket/contract:negative-position
this->*)]
let-bindings)))])))
(define-for-syntax (parse->*2 stx) (define-for-syntax (parse->*2 stx this->*)
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-dom ...) . other) [(_ (raw-mandatory-dom ...) . other)
(let () (let ()
@ -544,11 +550,11 @@
(with-syntax ([(man-dom (with-syntax ([(man-dom
man-dom-kwds man-dom-kwds
man-lets) man-lets)
(:split-doms stx '->* #'(raw-mandatory-dom ...))] (:split-doms stx '->* #'(raw-mandatory-dom ...) this->*)]
[(opt-dom [(opt-dom
opt-dom-kwds opt-dom-kwds
opt-lets) opt-lets)
(:split-doms stx '->* raw-optional-doms)]) (:split-doms stx '->* raw-optional-doms this->*)])
(values (values
#'man-dom #'man-dom
#'man-dom-kwds #'man-dom-kwds
@ -559,10 +565,11 @@
rest-ctc pre rng-ctcs post)))])) rest-ctc pre rng-ctcs post)))]))
(define-for-syntax (->*-valid-app-shapes stx) (define-for-syntax (->*-valid-app-shapes stx)
(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 rng-ctcs post) rest-ctc pre rng-ctcs post)
(parse->*2 stx)) (parse->*2 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))
@ -574,10 +581,11 @@
(define-syntax (->*2 stx) (define-syntax (->*2 stx)
(cond (cond
[(->*2-handled? stx) [(->*2-handled? stx)
(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 rng-ctcs post) rest-ctc pre rng-ctcs post)
(parse->*2 stx)) (parse->*2 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]
@ -604,25 +612,35 @@
rest-ctc rest-ctc
rng-ctcs rng-ctcs
(and post #'post-x))) (and post #'post-x)))
#`(let (mandatory-let-bindings ... (syntax-property
optional-let-bindings ... #`(let (mandatory-let-bindings ...
pre-let-binding ... optional-let-bindings ...
post-let-binding ...) pre-let-binding ...
(build--> '->* post-let-binding ...)
(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 #,@rng-ctcs) #,(if rng-ctcs
#'#f) #`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
#,(and post #t) (syntax-property rng-ctc
#,plus-one-arity-function 'racket/contract:positive-position
#,chaperone-constructor))))] this->*)))
#'#f)
#,(and post #t)
#,plus-one-arity-function
#,chaperone-constructor))
'racket/contract:contract
(vector this->*
;; the -> in the original input to this guy
(list (car (syntax-e stx)))
'()))))]
[else [else
(syntax-case stx () (syntax-case stx ()
[(_ args ...) [(_ args ...)