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

adjusted the annotations so that contracts can declare multiple parts

Browse Source 
of themselves to be colored and then used that so that the #:pre-cond
and #:post-cond keywords on ->i contracts are colored.
This commit is contained in:
Robby Findler 2010-07-13 04:44:11 -05:00
parent b664b04999
commit 18b8cde3e2
3 changed files with 38 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -80,8 +80,12 @@
[(pair? prop) (sloop (car prop)) (sloop (cdr prop))] [(pair? prop) (sloop (car prop)) (sloop (cdr prop))]
[(vector? prop) [(vector? prop)
(let ([id (vector-ref prop 0)] (let ([id (vector-ref prop 0)]
[to-color (vector-ref prop 1)]) [to-color-pos (vector-ref prop 1)]
(base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans) [to-color-neg (vector-ref prop 2)])
(for ((stx (in-list to-color-pos)))
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans))
(for ((stx (in-list to-color-neg)))
(base-color stx (not polarity) boundary-contract? my-coloring-plans client-coloring-plans))
(for ((stx (in-list (hash-ref domain-map id '())))) (for ((stx (in-list (hash-ref domain-map id '()))))
(do-contract-traversal stx boundary-contract? (do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans my-coloring-plans client-coloring-plans

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

@ -119,6 +119,26 @@
[(id . args) [(id . args)
(datum->syntax sstx (cons #'this-arg #'args) sstx)]))))) (datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
(define-for-syntax (find-pre/post-keywords stx)
(let ([pre #f]
[post #f])
(let loop ([stx (syntax->list stx)])
(cond
[(syntax? stx)
(loop (syntax-e stx))]
[(pair? stx)
(when (and (syntax? (car stx))
(eq? (syntax-e (car stx))
'#:pre-cond))
(set! pre (car stx)))
(when (and (syntax? (car stx))
(eq? (syntax-e (car stx))
'#:post-cond))
(set! post (car stx)))
(loop (cdr stx))]
[else (void)]))
(values pre post)))
(define-syntax (->i stx) (define-syntax (->i stx)
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-doms ...) [(_ (raw-mandatory-doms ...)
@ -250,9 +270,16 @@
(syntax-local-infer-name stx) (syntax-local-infer-name stx)
#`(λ args (apply f args))))) #`(λ args (apply f args)))))
'racket/contract:contract 'racket/contract:contract
(vector this->i (let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
;; the -> in the original input to this guy (vector this->i
(car (syntax-e stx)))) ;; the -> in the original input to this guy
(let ([kwd (list (car (syntax-e stx)))])
(if post-kwd
(cons post-kwd kwd)
kwd))
(if pre-kwd
(list pre-kwd)
'()))))
'racket/contract:internal-contract 'racket/contract:internal-contract
(gensym '->i-boundary)))))))))))])) (gensym '->i-boundary)))))))))))]))

3
collects/racket/contract/private/arrow.rkt
View File

@ -330,7 +330,8 @@ v4 todo:
'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
(car (syntax-e stx)))) (list (car (syntax-e stx)))
'()))
inner-args/body inner-args/body
(syntax (dom-names ... rng-names ...)))))))) (syntax (dom-names ... rng-names ...))))))))