From 40222e5daa5767c03ec0a879d18f1c733495a0de Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 4 Sep 2009 06:35:07 +0000 Subject: [PATCH] color assigned variables in red svn: r15873 --- collects/drscheme/syncheck.ss | 120 +++++++++++------- .../english-string-constants.ss | 1 + 2 files changed, 73 insertions(+), 48 deletions(-) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 68abb75be8..073fcc442f 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1355,9 +1355,11 @@ If the namespace does not, they are colored the unbound color. (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound) (define imported-variable-style-pref 'drscheme:check-syntax:imported) + (define set!d-variable-style-pref 'drscheme:check-syntax:set!d) (define lexically-bound-variable-style-name (symbol->string lexically-bound-variable-style-pref)) (define imported-variable-style-name (symbol->string imported-variable-style-pref)) + (define set!d-variable-style-name (symbol->string set!d-variable-style-pref)) (define error-style-name (fw:scheme:short-sym->style-name 'error)) ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant)) @@ -1370,12 +1372,20 @@ If the namespace does not, they are colored the unbound color. (fw:color-prefs:build-color-selection-panel parent imported-variable-style-pref imported-variable-style-name - (string-constant cs-imported-variable))) + (string-constant cs-imported-variable)) + (fw:color-prefs:build-color-selection-panel parent + set!d-variable-style-pref + set!d-variable-style-name + (string-constant cs-set!d-variable))) (fw:color-prefs:register-color-preference lexically-bound-variable-style-pref lexically-bound-variable-style-name (make-object color% 81 112 203) (make-object color% 50 163 255)) + (fw:color-prefs:register-color-preference set!d-variable-style-pref + set!d-variable-style-name + (send the-color-database find-color "firebrick") + (send the-color-database find-color "pink")) (fw:color-prefs:register-color-preference imported-variable-style-pref imported-variable-style-name (make-object color% 68 0 203) @@ -1415,6 +1425,8 @@ If the namespace does not, they are colored the unbound color. [tl-high-binders (make-id-set)] [tl-low-varrefs (make-id-set)] [tl-high-varrefs (make-id-set)] + [tl-low-varsets (make-id-set)] + [tl-high-varsets (make-id-set)] [tl-low-tops (make-id-set)] [tl-high-tops (make-id-set)] [tl-templrefs (make-id-set)] @@ -1434,6 +1446,8 @@ If the namespace does not, they are colored the unbound color. [high-binders (make-id-set)] [varrefs (make-id-set)] [high-varrefs (make-id-set)] + [varsets (make-id-set)] + [high-varsets (make-id-set)] [low-tops (make-id-set)] [high-tops (make-id-set)] [templrefs (make-id-set)] @@ -1443,7 +1457,10 @@ If the namespace does not, they are colored the unbound color. [require-for-labels (make-hash)]) (annotate-basic sexp user-namespace user-directory jump-to-id - low-binders high-binders varrefs high-varrefs low-tops high-tops + low-binders high-binders + varrefs high-varrefs + varsets high-varsets + low-tops high-tops templrefs requires require-for-syntaxes require-for-templates require-for-labels) (annotate-variables user-namespace @@ -1452,6 +1469,8 @@ If the namespace does not, they are colored the unbound color. high-binders varrefs high-varrefs + varsets + high-varsets low-tops high-tops templrefs @@ -1463,7 +1482,8 @@ If the namespace does not, they are colored the unbound color. (annotate-basic sexp user-namespace user-directory jump-to-id tl-low-binders tl-high-binders - tl-low-varrefs tl-high-varrefs + tl-low-varrefs tl-high-varrefs + tl-low-varsets tl-high-varsets tl-low-tops tl-high-tops tl-templrefs tl-requires @@ -1479,6 +1499,8 @@ If the namespace does not, they are colored the unbound color. tl-high-binders tl-low-varrefs tl-high-varrefs + tl-low-varsets + tl-high-varsets tl-low-tops tl-high-tops tl-templrefs @@ -1496,13 +1518,14 @@ If the namespace does not, they are colored the unbound color. ;; namespace ;; string[directory] ;; syntax[id] - ;; id-set (six of them) + ;; id-set (8 of them) ;; hash-table[require-spec -> syntax] (three of them) ;; -> void (define (annotate-basic sexp user-namespace user-directory jump-to-id low-binders high-binders low-varrefs high-varrefs + low-varsets high-varsets low-tops high-tops templrefs requires require-for-syntaxes require-for-templates require-for-labels) @@ -1524,6 +1547,7 @@ If the namespace does not, they are colored the unbound color. (let* ([loop (λ (sexp) (level-loop sexp high-level?))] [varrefs (if high-level? high-varrefs low-varrefs)] + [varsets (if high-level? high-varsets low-varsets)] [binders (if high-level? high-binders low-binders)] [tops (if high-level? high-tops low-tops)] [collect-general-info @@ -1611,6 +1635,7 @@ If the namespace does not, they are colored the unbound color. ;; tops are used here because a binding free use of a set!'d variable ;; is treated just the same as (#%top . x). (when (syntax-original? (syntax var)) + (add-id varsets (syntax var)) (if (identifier-binding (syntax var) 0) (add-id varrefs (syntax var)) (add-id tops (syntax var)))) @@ -1811,6 +1836,8 @@ If the namespace does not, they are colored the unbound color. high-binders low-varrefs high-varrefs + low-varsets + high-varsets low-tops high-tops templrefs @@ -1852,47 +1879,44 @@ If the namespace does not, they are colored the unbound color. (hash-for-each require-for-labels (lambda (k v) (hash-set! unused-require-for-labels k #t))) - (for-each (λ (vars) - (for-each (λ (var) - (when (syntax-original? var) - (color-variable var 0) - (document-variable var 0) - (record-renamable-var rename-ht var))) - vars)) - (append (get-idss high-binders) - (get-idss low-binders))) + (let ([handle-var-bind + (λ (var varsets) + (when (syntax-original? var) + (color-variable var 0 varsets) + (document-variable var 0) + (record-renamable-var rename-ht var)))]) + (for-each (λ (vars) + (for-each (λ (var) (handle-var-bind var high-varsets)) + vars)) + (get-idss high-binders)) + (for-each (λ (vars) + (for-each (λ (var) (handle-var-bind var low-varsets)) + vars)) + (get-idss low-binders))) - (for-each (λ (vars) (for-each - (λ (var) - (color-variable var 0) - (document-variable var 0) - (connect-identifier var - rename-ht - low-binders - unused/phases - requires/phases - 0 - user-namespace - user-directory - #t)) - vars)) - (get-idss low-varrefs)) - (for-each (λ (vars) (for-each - (λ (var) - (color-variable var 1) - (document-variable var 1) - (connect-identifier var - rename-ht - high-binders - unused/phases - requires/phases - 1 - user-namespace - user-directory - #t)) - vars)) - (get-idss high-varrefs)) + (let ([handle-var-ref + (λ (var index binders varsets) + (color-variable var index varsets) + (document-variable var index) + (connect-identifier var + rename-ht + binders + unused/phases + requires/phases + index + user-namespace + user-directory + #t))]) + (for-each (λ (vars) (for-each + (λ (var) (handle-var-ref var 0 low-binders low-varsets)) + vars)) + (get-idss low-varrefs)) + + (for-each (λ (vars) (for-each + (λ (var) (handle-var-ref var 1 high-binders high-varsets)) + vars)) + (get-idss high-varrefs))) (for-each (lambda (vars) (for-each (lambda (var) @@ -2115,8 +2139,8 @@ If the namespace does not, they are colored the unbound color. (color var error-style-name)) (connect-identifier var rename-ht binders #f #f 0 user-namespace user-directory #t))) - ;; color-variable : syntax phase-level -> void - (define (color-variable var phase-level) + ;; color-variable : syntax phase-level module-identifier-mapping -> void + (define (color-variable var phase-level varsets) (let* ([b (identifier-binding var phase-level)] [lexical? (or (not b) @@ -2128,6 +2152,8 @@ If the namespace does not, they are colored the unbound color. (and (not a) (not b)))))))]) (cond + [(module-identifier-mapping-get varsets var (λ () #f)) + (color var set!d-variable-style-name)] [lexical? (color var lexically-bound-variable-style-name)] [(pair? b) (color var imported-variable-style-name)]))) @@ -2258,9 +2284,7 @@ If the namespace does not, they are colored the unbound color. (parameterize ([current-namespace user-namespace] [current-directory user-directory] [current-load-relative-directory user-directory]) - (let ([ans (with-handlers ([exn:fail? (λ (x) - (printf "fail ~s\n" (exn-message x)) - #f)]) + (let ([ans (with-handlers ([exn:fail? (λ (x) #f)]) (cond [(module-path-index? datum) (resolved-module-path-name diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 2008635da3..cccb684eba 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -195,6 +195,7 @@ please adhere to these guidelines: (cs-view-docs-from "~a from ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use (cs-lexical-variable "lexical variable") + (cs-set!d-variable "set!’d variable") (cs-imported-variable "imported variable") ;;; info bar at botttom of drscheme frame