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

started on a better way to do the obligation coloring

Browse Source
This commit is contained in:
Robby Findler 2010-07-11 16:54:50 -05:00
parent 8a67fceb4a
commit f1e1887fee
3 changed files with 48 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/drracket/syncheck.rkt
View File

@ -2108,6 +2108,30 @@ If the namespace does not, they are colored the unbound color.
(color-unused requires unused-requires)
(hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
(define (annotate-contracts stx)
(define start-map (make-hash))
(define arrow-map (make-hash))
(define domain-map (make-hash))
(define range-map (make-hash))
(define (add-to-map stx prop map)
(let loop ([val (syntax-property stx prop)])
(cond
[(symbol? val)
(hash-set! map val (cons stx (hash-ref map val '())))]
[(pair? val)
(loop (car val))
(loop (cdr val))])))
(let loop ([stx stx])
(add-to-map stx 'racket/contract:contract-on-boundary start-map)
(add-to-map stx 'racket/contract:domain-of domain-map)
(add-to-map stx 'racket/contract:rng-of range-map)
(add-to-map stx 'racket/contract:function-contract arrow-map)
(syntax-case stx ()
[(a . b) (loop #'a) (loop #'b)]
[else (void)])))
#|
(define (annotate-contracts stx)
(let loop ([stx stx])
(let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
@ -2141,7 +2165,7 @@ If the namespace does not, they are colored the unbound color.
(base-color stx polarity)]
[else
(color stx unk-obligation-style-name 'contract-mode)])))
|#
;; returns #t if the result is known to be a predicate that shoudl correspond to a
;; complete obligation for the contract. If it is some unknown variable, this variable
;; may refer to some other contract with nested obligations, so we have to return #f here.

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

@ -350,14 +350,18 @@ v4 todo:
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)
(let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
(let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)]
[(this->) (gensym 'this->)])
(with-syntax ([(args body) inner-args/body])
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(kwd-names ...) kwd-names]
[(dom-ctcs ...) dom-ctcs]
[(rng-ctcs ...) rng-ctcs]
[(kwd-ctcs ...) kwd-ctcs]
[(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
(syntax->list dom-ctcs))]
[(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:rng-of this->))
(syntax->list rng-ctcs))]
[(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
(syntax->list kwd-ctcs))]
[(kwds ...) kwds]
[inner-lambda
(maybe-a-method/name
@ -371,12 +375,15 @@ v4 todo:
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function inner-lambda ctc)))])
(values
(syntax
(build--> '->
(list dom-ctcs ...) '() #f
(list kwd-ctcs ...) '(kwds ...) '() '()
(list rng-ctcs ...) use-any?
outer-lambda))
(syntax-property
(syntax
(build--> '->
(list dom-ctcs ...) '() #f
(list kwd-ctcs ...) '(kwds ...) '() '()
(list rng-ctcs ...) use-any?
outer-lambda))
'racket/contract:function-contract
this->)
inner-args/body
(syntax (dom-names ... rng-names ...))))))))

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

@ -663,9 +663,12 @@
(code-for-one-id/new-name stx id reflect-id ctrct user-rename-id #f #t)]
[(stx id reflect-id ctrct user-rename-id mangle-for-maker?)
(code-for-one-id/new-name id reflect-id ctrct user-rename-id mangle-for-maker? #t)]
[(stx id reflect-id ctrct user-rename-id mangle-for-maker? provide?)
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]
[ex-id (or reflect-id id)])
[(stx id reflect-id ctrct/no-prop user-rename-id mangle-for-maker? provide?)
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
[ex-id (or reflect-id id)]
[ctrct (syntax-property ctrct/no-prop
'racket/contract:contract-on-boundary
(gensym 'provide/contract-boundary))])
(with-syntax ([id-rename ((if mangle-for-maker?
a:mangle-id-for-maker
a:mangle-id)