various cleanups, including finishing up the client mode, string constants, and coloring of (known) identifiers

This commit is contained in:
Robby Findler 2010-07-12 15:46:22 -05:00
parent b9ff546e83
commit 4eb3df7094
4 changed files with 179 additions and 105 deletions

View File

@ -7,16 +7,20 @@
(provide annotate-contracts)
(define (annotate-contracts stx low-binders binding-inits)
(define start-map (make-hash))
(define boundary-start-map (make-hash))
(define internal-start-map (make-hash))
(define arrow-map (make-hash))
(define domain-map (make-hash))
(define range-map (make-hash))
;; coloring-plans : hash[stx -o-> (listof color)]
(define coloring-plans (make-hash))
;; my-coloring-plans : hash[stx -o-> (listof color)]
(define my-coloring-plans (make-hash))
;; client-coloring-plans : hash[stx -o-> (listof color)]
(define client-coloring-plans (make-hash))
(let loop ([stx stx])
(add-to-map stx 'racket/contract:contract-on-boundary start-map)
(add-to-map stx 'racket/contract:contract-on-boundary boundary-start-map)
(add-to-map stx 'racket/contract:internal-contract internal-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)
@ -24,32 +28,48 @@
[(a . b) (loop #'a) (loop #'b)]
[else (void)]))
;; fill in the coloring-plans table
(for ([(start-k start-val) (in-hash start-map)])
;; fill in the coloring-plans table for boundary contracts
(for ([(start-k start-val) (in-hash boundary-start-map)])
(for ([start-stx (in-list start-val)])
(do-contract-traversal start-stx
coloring-plans
(do-contract-traversal start-stx #t
my-coloring-plans client-coloring-plans
low-binders binding-inits
arrow-map domain-map range-map
#t)))
;; fill in the coloring-plans table for internal contracts
(for ([(start-k start-val) (in-hash internal-start-map)])
(for ([start-stx (in-list start-val)])
(do-contract-traversal start-stx #f
my-coloring-plans client-coloring-plans
low-binders binding-inits
arrow-map domain-map range-map
#t)))
;; enact the coloring plans
(for ([(stx colors) (in-hash coloring-plans)])
(cond
[(and (member my-obligation-style-name colors)
(member their-obligation-style-name colors))
(color stx both-obligation-style-name 'contract-mode)]
[(member my-obligation-style-name colors)
(color stx my-obligation-style-name 'contract-mode)]
[(member their-obligation-style-name colors)
(color stx their-obligation-style-name 'contract-mode)]
[(member unk-obligation-style-name colors)
(color stx unk-obligation-style-name 'contract-mode)])))
(for ((coloring-plans (in-list (list my-coloring-plans client-coloring-plans)))
(mode (in-list '(my-obligations-mode client-obligations-mode))))
(for ([(stx colors) (in-hash coloring-plans)])
(cond
[(and (member my-obligation-style-name colors)
(member their-obligation-style-name colors))
(color stx both-obligation-style-name mode)]
[(member my-obligation-style-name colors)
(color stx my-obligation-style-name mode)]
[(member their-obligation-style-name colors)
(color stx their-obligation-style-name mode)]
[(member unk-obligation-style-name colors)
(color stx unk-obligation-style-name mode)]))))
(define (do-contract-traversal start-stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
(define (do-contract-traversal start-stx boundary-contract?
my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)
(let ploop ([stx start-stx]
[polarity polarity])
(define (call-give-up)
(give-up start-stx boundary-contract? my-coloring-plans client-coloring-plans))
(let ([main-prop (syntax-property stx 'racket/contract:contract)])
(cond
[main-prop
@ -61,11 +81,15 @@
[(vector? prop)
(let ([id (vector-ref prop 0)]
[to-color (vector-ref prop 1)])
(base-color to-color polarity coloring-plans)
(base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
(for ((stx (in-list (hash-ref domain-map id '()))))
(do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map (not polarity)))
(do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map (not polarity)))
(for ((stx (in-list (hash-ref range-map id '()))))
(do-contract-traversal stx coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)))]))]
(do-contract-traversal stx boundary-contract?
my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)))]))]
[else
;; we didn't find a contract, but we might find one in a subexpression
@ -74,33 +98,44 @@
[(#%expression expr)
(ploop #'expr polarity)]
[(module id name-id (#%plain-module-begin mod-level-form ...))
(give-up start-stx coloring-plans)]
(call-give-up)]
[(begin tl-form ... last-one)
(ploop #'last-one polarity)]
[(#%provide pvd ...)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(define-values (id ...) expr)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(define-syntaxes (id ...) expr)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(define-values-for-syntax (id ...) expr)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(#%require rspec ...)
(give-up start-stx coloring-plans)]
(call-give-up)]
[id
(identifier? #'id)
(if (known-predicate? #'id)
(base-color #'id polarity coloring-plans)
(base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
(let ([binders (module-identifier-mapping-get low-binders #'id (λ () #f))])
(if binders
(for ((binder (in-list (module-identifier-mapping-get low-binders #'id))))
(for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
(ploop rhs polarity)))
(give-up start-stx coloring-plans))))]
(begin
(base-color #'id polarity boundary-contract? my-coloring-plans client-coloring-plans)
(for ((binder (in-list (module-identifier-mapping-get low-binders #'id))))
(base-color binder polarity boundary-contract? my-coloring-plans client-coloring-plans)
(for ((rhs (in-list (module-identifier-mapping-get binding-inits binder))))
(ploop rhs polarity))))
(call-give-up))))]
[(#%plain-lambda (id) expr ...)
(identifier? #'id)
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
[(#%plain-lambda id expr ...)
(identifier? #'id)
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
[(#%plain-lambda formals expr ...)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(case-lambda [formals expr] ...)
(give-up start-stx coloring-plans)]
;; this should really only happen when the arity of the case-lambda includes 1
;; (otherwise we should call give-up)
(base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)]
[(if a b c)
;; these calls are questionable.
;; if we ultimately end up giving up in both
@ -110,8 +145,12 @@
;; on the other hand, recurring like this will mean that the two
;; branches are considered separately and thus calling give-up
;; on one side will not pollute the other side.
(do-contract-traversal #'b coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)
(do-contract-traversal #'c coloring-plans low-binders binding-inits arrow-map domain-map range-map polarity)]
(do-contract-traversal #'b boundary-contract?
my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)
(do-contract-traversal #'c boundary-contract?
my-coloring-plans client-coloring-plans
low-binders binding-inits arrow-map domain-map range-map polarity)]
;; [(begin expr ...) (void)]
[(begin0 fst rst ...)
(ploop #'fst polarity)]
@ -120,19 +159,19 @@
[(letrec-values bindings body ... last-one)
(ploop #'last-one polarity)]
[(set! a b)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(quote stuff)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(quote-syntax stuff)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(with-continuation-mark a b c)
(ploop #'c polarity)]
[(#%plain-app f args ...)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(#%top . id)
(give-up start-stx coloring-plans)]
(call-give-up)]
[(#%variable-reference ignored ...)
(give-up start-stx coloring-plans)])]))))
(call-give-up)])]))))
;; add-to-map : syntax any hash[any -> (listof stx)]
;; looks at stx's property prop and updates map,
@ -158,31 +197,39 @@
(let-values ([(base rel) (module-path-index-split src)])
(member base '('#%kernel racket racket/base scheme scheme/base)))))))
(define (give-up stx coloring-plans)
(define (give-up stx boundary-contract? my-coloring-plans client-coloring-plans)
(let loop ([stx stx])
(when (syntax-original? stx)
(blank-color stx coloring-plans))
(blank-color stx boundary-contract? my-coloring-plans client-coloring-plans))
(let oloop ([origin (syntax-property stx 'origin)])
(cond
[(pair? origin) (oloop (car origin)) (oloop (cdr origin))]
[(syntax? origin)
(when (syntax-original? origin)
(blank-color origin coloring-plans))]))
(blank-color origin boundary-contract? my-coloring-plans client-coloring-plans))]))
(syntax-case stx ()
[(a . b) (loop #'a) (loop #'b)]
[_ (void)])))
(define (base-color stx polarity boundary-contract? my-coloring-plans client-coloring-plans)
(let ([style (if polarity my-obligation-style-name their-obligation-style-name)]
[neg-style (if polarity their-obligation-style-name my-obligation-style-name)])
(cond
[boundary-contract?
(make-a-coloring-plan stx style my-coloring-plans)
(make-a-coloring-plan stx neg-style client-coloring-plans)]
[else
(make-a-coloring-plan stx style my-coloring-plans)])))
(define (base-color stx polarity coloring-plans)
(make-a-coloring-plan stx
(if polarity my-obligation-style-name their-obligation-style-name)
coloring-plans))
(define (blank-color stx coloring-plans)
(make-a-coloring-plan stx unk-obligation-style-name coloring-plans))
(define (blank-color stx boundary-contract? my-coloring-plans client-coloring-plans)
(cond
[boundary-contract?
(make-a-coloring-plan stx unk-obligation-style-name my-coloring-plans)
(make-a-coloring-plan stx unk-obligation-style-name client-coloring-plans)]
[else
(make-a-coloring-plan stx unk-obligation-style-name my-coloring-plans)]))
(define (make-a-coloring-plan stx plan coloring-plans)
(hash-set! coloring-plans

View File

@ -57,10 +57,10 @@ If the namespace does not, they are colored the unbound color.
(define jump-to-binding (string-constant cs-jump-to-binding))
(define jump-to-definition (string-constant cs-jump-to-definition))
(define cs-mode-menu-show-contract "Show Contract Obligations")
(define cs-mode-menu-show-syntax "Show Syntactic Categories")
(define cs-check-syntax-mode (string-constant cs-check-syntax-mode))
(define cs-mode-menu-show-my-obligations (string-constant cs-mode-menu-show-my-obligations))
(define cs-mode-menu-show-client-obligations (string-constant cs-mode-menu-show-client-obligations))
(define cs-mode-menu-show-syntax (string-constant cs-mode-menu-show-syntax))
(define tool@
(unit
@ -341,6 +341,9 @@ If the namespace does not, they are colored the unbound color.
(when f
(send f open-status-line 'drracket:check-syntax:mouse-over))))
(define/public (syncheck:arrows-visible?)
(or arrow-vectors cursor-location cursor-text))
;; syncheck:clear-arrows : -> void
(define/public (syncheck:clear-arrows)
(when (or arrow-vectors cursor-location cursor-text)
@ -988,23 +991,25 @@ If the namespace does not, they are colored the unbound color.
(syncheck:clear-highlighting))
(define/public (syncheck:clear-error-message)
(set! error-report-visible? #f)
(send report-error-text clear-output-ports)
(send report-error-text lock #f)
(send report-error-text delete/io 0 (send report-error-text last-position))
(send report-error-text lock #t)
(when (is-current-tab?)
(send (get-frame) hide-error-report)
(send (get-frame) update-menu-item-label this)))
(unless error-report-visible?
(set! error-report-visible? #f)
(send report-error-text clear-output-ports)
(send report-error-text lock #f)
(send report-error-text delete/io 0 (send report-error-text last-position))
(send report-error-text lock #t)
(when (is-current-tab?)
(send (get-frame) hide-error-report)
(send (get-frame) update-menu-status this))))
(define/public (syncheck:clear-highlighting)
(let* ([definitions (get-defs)]
[locked? (send definitions is-locked?)])
(send definitions begin-edit-sequence #f)
(send definitions lock #f)
(send definitions syncheck:clear-arrows)
(send definitions lock locked?)
(send definitions end-edit-sequence)))
(let ([definitions (get-defs)])
(when (send definitions syncheck:arrows-visible?)
(let ([locked? (send definitions is-locked?)])
(send definitions begin-edit-sequence #f)
(send definitions lock #f)
(send definitions syncheck:clear-arrows)
(send definitions lock locked?)
(send definitions end-edit-sequence)))))
(define/augment (can-close?)
(and (send report-error-text can-close?)
@ -1032,7 +1037,7 @@ If the namespace does not, they are colored the unbound color.
(show-error-report)
(hide-error-report))
(send report-error-canvas set-editor (send new-tab get-error-report-text))
(update-menu-item-label new-tab)
(update-menu-status new-tab)
(update-button-visibility/tab new-tab))
(define/private (update-button-visibility/tab tab)
@ -1049,11 +1054,13 @@ If the namespace does not, they are colored the unbound color.
(define/augment (enable-evaluation)
(send check-syntax-button enable #t)
(send mode-menu-item enable #t)
(send mode-menu-item1 enable #t)
(send mode-menu-item2 enable #t)
(inner (void) enable-evaluation))
(define/augment (disable-evaluation)
(send mode-menu-item enable #f)
(send mode-menu-item1 enable #f)
(send mode-menu-item2 enable #f)
(send check-syntax-button enable #f)
(inner (void) disable-evaluation))
@ -1115,36 +1122,47 @@ If the namespace does not, they are colored the unbound color.
(set! rest-panel r-root)
r-root))
(define mode-menu-item #f)
(define mode-menu-item1 #f)
(define mode-menu-item2 #f)
(define mode-menu-item3 #f)
(define/override (add-show-menu-items show-menu)
(define (start-checking mode)
(let* ([tab (get-current-tab)]
[defs (send tab get-defs)])
(cond
[(send defs get-syncheck-mode)
(send defs set-syncheck-mode mode)
(update-menu-status tab)]
[else
(syncheck:button-callback #f mode)])))
(super add-show-menu-items show-menu)
(set! mode-menu-item
(new menu-item%
[parent show-menu]
[label ""]
[callback
(λ (a b)
(let ([defs (send (get-current-tab) get-defs)])
(case (send defs get-syncheck-mode)
[(#f) (syncheck:button-callback #f 'contract-mode)]
[(default-mode)
(send defs set-syncheck-mode 'contract-mode)
(update-menu-item-label (get-current-tab))]
[else
(send defs set-syncheck-mode 'default-mode)
(update-menu-item-label (get-current-tab))])))])))
(let ([p (new menu%
[parent show-menu]
[label cs-check-syntax-mode])])
(set! mode-menu-item1
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-syntax]
[callback (λ (a b) (start-checking 'default-mode))]))
(set! mode-menu-item2
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-my-obligations]
[callback (λ (a b) (start-checking 'my-obligations-mode))]))
(set! mode-menu-item3
(new checkable-menu-item%
[parent p]
[label cs-mode-menu-show-client-obligations]
[callback (λ (a b) (start-checking 'client-obligations-mode))]))))
(define/public (update-menu-item-label tab)
(when mode-menu-item
(define/public (update-menu-status tab)
(when mode-menu-item1
(let ([mode (send (send (get-current-tab) get-defs) get-syncheck-mode)])
(case mode
[(#f)
(send mode-menu-item set-label cs-mode-menu-show-contract)]
[(default-mode)
(send mode-menu-item set-label cs-mode-menu-show-contract)]
[(contract-mode)
(send mode-menu-item set-label cs-mode-menu-show-syntax)]))))
(send mode-menu-item1 check (eq? mode 'default-mode))
(send mode-menu-item2 check (eq? mode 'my-obligations-mode))
(send mode-menu-item3 check (eq? mode 'client-obligations-mode)))))
(inherit open-status-line close-status-line update-status-line ensure-rep-hidden)
;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void)
@ -1276,7 +1294,7 @@ If the namespace does not, they are colored the unbound color.
(parameterize ([currently-processing-definitions-text definitions-text])
(expansion-completed user-namespace user-directory)
(send (send (get-current-tab) get-defs) set-syncheck-mode mode)
(update-menu-item-label (get-current-tab))
(update-menu-status (get-current-tab))
(send definitions-text syncheck:sort-bindings-table))))
(cleanup)
(custodian-shutdown-all user-custodian))))]

View File

@ -7,6 +7,7 @@
(define-local-member-name
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:add-arrow
syncheck:add-tail-arrow
@ -34,12 +35,13 @@
set-syncheck-mode
get-syncheck-mode
update-menu-item-label)
update-menu-status)
(define syncheck-text<%>
(interface ()
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:add-arrow
syncheck:add-tail-arrow
@ -74,6 +76,7 @@
;; methods
syncheck:init-arrows
syncheck:clear-arrows
syncheck:arrows-visible?
syncheck:add-menu
syncheck:add-arrow
syncheck:add-tail-arrow
@ -101,4 +104,4 @@
set-syncheck-mode
get-syncheck-mode
update-menu-item-label)
update-menu-status)

View File

@ -197,6 +197,12 @@ please adhere to these guidelines:
(cs-set!d-variable "set!d variable")
(cs-imported-variable "imported variable")
;; mode sub-menu in the "view" menu
(cs-check-syntax-mode "Check Syntax Mode")
(cs-mode-menu-show-my-obligations "My Contract Obligations")
(cs-mode-menu-show-client-obligations "Client Contract Obligations")
(cs-mode-menu-show-syntax "Syntactic Categories")
;;; info bar at botttom of drscheme frame
(collect-button-label "GC")
(read-only "Read only")