started on a better way to do the obligation coloring
This commit is contained in:
parent
8a67fceb4a
commit
f1e1887fee
|
@ -2108,6 +2108,30 @@ If the namespace does not, they are colored the unbound color.
|
||||||
(color-unused requires unused-requires)
|
(color-unused requires unused-requires)
|
||||||
(hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets)))))
|
(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)
|
(define (annotate-contracts stx)
|
||||||
(let loop ([stx stx])
|
(let loop ([stx stx])
|
||||||
(let sloop ([prop (syntax-property stx 'provide/contract-original-contract)])
|
(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)]
|
(base-color stx polarity)]
|
||||||
[else
|
[else
|
||||||
(color stx unk-obligation-style-name 'contract-mode)])))
|
(color stx unk-obligation-style-name 'contract-mode)])))
|
||||||
|
|#
|
||||||
;; returns #t if the result is known to be a predicate that shoudl correspond to a
|
;; 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
|
;; 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.
|
;; may refer to some other contract with nested obligations, so we have to return #f here.
|
||||||
|
|
|
@ -350,14 +350,18 @@ v4 todo:
|
||||||
|
|
||||||
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||||
(define-for-syntax (->/proc/main stx)
|
(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 ([(args body) inner-args/body])
|
||||||
(with-syntax ([(dom-names ...) dom-names]
|
(with-syntax ([(dom-names ...) dom-names]
|
||||||
[(rng-names ...) rng-names]
|
[(rng-names ...) rng-names]
|
||||||
[(kwd-names ...) kwd-names]
|
[(kwd-names ...) kwd-names]
|
||||||
[(dom-ctcs ...) dom-ctcs]
|
[(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
|
||||||
[(rng-ctcs ...) rng-ctcs]
|
(syntax->list dom-ctcs))]
|
||||||
[(kwd-ctcs ...) kwd-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]
|
[(kwds ...) kwds]
|
||||||
[inner-lambda
|
[inner-lambda
|
||||||
(maybe-a-method/name
|
(maybe-a-method/name
|
||||||
|
@ -371,12 +375,15 @@ v4 todo:
|
||||||
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
||||||
(make-contracted-function inner-lambda ctc)))])
|
(make-contracted-function inner-lambda ctc)))])
|
||||||
(values
|
(values
|
||||||
(syntax
|
(syntax-property
|
||||||
(build--> '->
|
(syntax
|
||||||
(list dom-ctcs ...) '() #f
|
(build--> '->
|
||||||
(list kwd-ctcs ...) '(kwds ...) '() '()
|
(list dom-ctcs ...) '() #f
|
||||||
(list rng-ctcs ...) use-any?
|
(list kwd-ctcs ...) '(kwds ...) '() '()
|
||||||
outer-lambda))
|
(list rng-ctcs ...) use-any?
|
||||||
|
outer-lambda))
|
||||||
|
'racket/contract:function-contract
|
||||||
|
this->)
|
||||||
inner-args/body
|
inner-args/body
|
||||||
(syntax (dom-names ... rng-names ...))))))))
|
(syntax (dom-names ... rng-names ...))))))))
|
||||||
|
|
||||||
|
|
|
@ -663,9 +663,12 @@
|
||||||
(code-for-one-id/new-name stx id reflect-id ctrct user-rename-id #f #t)]
|
(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?)
|
[(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)]
|
(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?)
|
[(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)]
|
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
|
||||||
[ex-id (or reflect-id id)])
|
[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?
|
(with-syntax ([id-rename ((if mangle-for-maker?
|
||||||
a:mangle-id-for-maker
|
a:mangle-id-for-maker
|
||||||
a:mangle-id)
|
a:mangle-id)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user