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))]
[(vector? prop)
(let ([id (vector-ref prop 0)]
[to-color (vector-ref prop 1)])
(base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
[to-color-pos (vector-ref prop 1)]
[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 '()))))
(do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans

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

@ -119,6 +119,26 @@
[(id . args)
(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)
(syntax-case stx ()
[(_ (raw-mandatory-doms ...)
@ -250,9 +270,16 @@
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))
'racket/contract:contract
(let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
(vector this->i
;; the -> in the original input to this guy
(car (syntax-e stx))))
(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
(gensym '->i-boundary)))))))))))]))

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

@ -330,7 +330,8 @@ v4 todo:
'racket/contract:contract
(vector this->
;; the -> in the original input to this guy
(car (syntax-e stx))))
(list (car (syntax-e stx)))
'()))
inner-args/body
(syntax (dom-names ... rng-names ...))))))))