From b5ccbb45bdf9b64f5ea6231bbd4ed627e60664ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 14 Feb 2009 16:03:42 +0000 Subject: [PATCH] branch svn: r13579 --- collects/drscheme/private/mred-typed.ss | 103 + collects/drscheme/private/prefs-contract.ss | 16 - collects/drscheme/syncheck/annotate.ss | 634 ++++ collects/drscheme/syncheck/color.ss | 84 + collects/drscheme/syncheck/extra-stxcase.ss | 44 + collects/drscheme/syncheck/extra-typed.ss | 453 +++ collects/drscheme/syncheck/extra.ss | 21 + collects/drscheme/syncheck/id-sets.ss | 41 + collects/drscheme/syncheck/make-traversal.ss | 86 + collects/drscheme/syncheck/syncheck.ss | 2755 ++++++++++++++++++ collects/drscheme/syncheck/utils.ss | 8 + 11 files changed, 4229 insertions(+), 16 deletions(-) create mode 100644 collects/drscheme/private/mred-typed.ss delete mode 100644 collects/drscheme/private/prefs-contract.ss create mode 100644 collects/drscheme/syncheck/annotate.ss create mode 100644 collects/drscheme/syncheck/color.ss create mode 100644 collects/drscheme/syncheck/extra-stxcase.ss create mode 100644 collects/drscheme/syncheck/extra-typed.ss create mode 100644 collects/drscheme/syncheck/extra.ss create mode 100644 collects/drscheme/syncheck/id-sets.ss create mode 100644 collects/drscheme/syncheck/make-traversal.ss create mode 100644 collects/drscheme/syncheck/syncheck.ss create mode 100644 collects/drscheme/syncheck/utils.ss diff --git a/collects/drscheme/private/mred-typed.ss b/collects/drscheme/private/mred-typed.ss new file mode 100644 index 0000000000..e906dbc81a --- /dev/null +++ b/collects/drscheme/private/mred-typed.ss @@ -0,0 +1,103 @@ +#lang planet plt typed-scheme.plt 3 1 + +;(require mred/mred) +(provide (all-defined-out)) + +(define-type-alias Bitmap% (Class (Number Number Boolean) + () + ([get-width (-> Number)] + [get-height (-> Number)]))) +(define-type-alias Font-List% (Class () () ([find-or-create-font (Any .. -> (Instance Font%))]))) +(define-type-alias Font% (Class () () ([get-face (-> (Option String))] + [get-point-size (-> Number)]))) +(define-type-alias Dialog% (Class () + ([parent Any] [width Number] [label String]) + ([show (Any -> Void)]))) +(define-type-alias Text-Field% (Class () + ([parent Any] [callback Any] [label String]) + ([get-value (-> String)] + [focus (-> String)]))) +(define-type-alias Horizontal-Panel% (Class () + ([parent Any] + [stretchable-height Any #t] + [alignment (List Symbol Symbol) #t]) + ())) +(define-type-alias Choice% (Class () + ([parent Any] [label String] [choices List] [callback Any]) + ([get-string-selection (-> (Option String))] + [set-string-selection (String -> Void)]))) +(define-type-alias Message% (Class () + ([parent Any] [label String]) + ([set-label ((U String (Instance Bitmap%)) -> Void)]))) +(define-type-alias Horizontal-Pane% (Class () + ([parent Any]) + ())) +(define-type-alias Editor-Canvas% (Class () + ([parent Any] [editor Any]) + ([set-line-count (Number -> Void)]))) +(define-type-alias Bitmap-DC% (Class ((Instance Bitmap%)) + () + ([get-text-extent (String (Instance Font%) -> (values Number Number Number Number))] + [get-pixel (Number Number (Instance Color%) -> Boolean)] + [set-bitmap ((Option (Instance Bitmap%)) -> Void)] + [clear (-> Void)] + [set-font ((Instance Font%) -> Void)] + [draw-text (String Number Number -> Void)]))) +(define-type-alias Color% (Class () () ([red (-> Number)]))) +(define-type-alias Style-List% (Class () + () + ([find-named-style + (String -> (Instance (Class () + () + ([get-font (-> (Instance Font%))]))))]))) + +(define-type-alias Scheme:Text% (Class () + () + ([begin-edit-sequence (-> Void)] + [end-edit-sequence (-> Void)] + [lock (Boolean -> Void)] + [last-position (-> Number)] + [last-paragraph (-> Number)] + [delete (Number Number -> Void)] + [auto-wrap (Any -> Void)] + [paragraph-end-position (Number -> Number)] + [paragraph-start-position (Number -> Number)] + [get-start-position (-> Number)] + [get-end-position (-> Number)] + [insert (String Number Number -> Void)]))) + +(require/typed mred/mred + [the-font-list (Instance Font-List%)] + [dialog% Dialog%] + [text-field% Text-Field%] + [horizontal-panel% Horizontal-Panel%] + [choice% Choice%] + [get-face-list (-> (Listof String))] + [message% Message%] + [horizontal-pane% Horizontal-Pane%] + [editor-canvas% Editor-Canvas%] + [bitmap-dc% Bitmap-DC%] + [bitmap% Bitmap%] + [color% Color%]) + +(require/typed framework/framework + [preferences:set-default (Symbol Any Any -> Void)] + [preferences:set (Symbol Any -> Void)] + [editor:get-standard-style-list + (-> (Instance Style-List%))] + [scheme:text% Scheme:Text%] + [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))]) + +(require/typed "prefs-contract.ss" + [preferences:get-drscheme:large-letters-font (-> (Pair Symbol Number))]) + +(require (only-in "prefs-contract.ss" preferences:get)) +(provide preferences:get preferences:get-drscheme:large-letters-font) + +(define-type-alias Bitmap-Message% (Class () + ([parent Any]) + ([set-bm ((Instance Bitmap%) -> Void)]))) + + +(require/typed "bitmap-message.ss" + [bitmap-message% Bitmap-Message%]) \ No newline at end of file diff --git a/collects/drscheme/private/prefs-contract.ss b/collects/drscheme/private/prefs-contract.ss deleted file mode 100644 index dd62fb14d3..0000000000 --- a/collects/drscheme/private/prefs-contract.ss +++ /dev/null @@ -1,16 +0,0 @@ -#lang scheme/base - -(require (for-syntax scheme/base) - framework/framework) - -(provide (rename-out [-preferences:get preferences:get]) - preferences:get-drscheme:large-letters-font) - -(define (preferences:get-drscheme:large-letters-font) - (preferences:get 'drscheme:large-letters-font)) - -(define-syntax (-preferences:get stx) - (syntax-case stx (quote) - [(_ (quote sym)) - (with-syntax ([nm (datum->syntax stx (string->symbol (string-append "preferences:get" "-" (symbol->string (syntax-e #'sym)))))]) - (syntax/loc stx (nm)))])) diff --git a/collects/drscheme/syncheck/annotate.ss b/collects/drscheme/syncheck/annotate.ss new file mode 100644 index 0000000000..087aba6e3b --- /dev/null +++ b/collects/drscheme/syncheck/annotate.ss @@ -0,0 +1,634 @@ +#lang scheme/base + +(provide (all-defined-out)) + +(require string-constants/string-constant + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/bitmap-label + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred/mred + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base) + "extra-stxcase.ss" + "id-sets.ss" + "extra-typed.ss" + "utils.ss") + + + ; + ; + ; + ; ; + ; ; + ; ; ; ; + ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; + ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; + ; ; + ; ; + ; ; + + + + ;; annotate-basic : syntax + ;; namespace + ;; string[directory] + ;; syntax[id] + ;; id-set (six 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-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (let ([tail-ht (make-hash-table)] + [maybe-jump + (λ (vars) + (when jump-to-id + (for-each (λ (id) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; 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)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + ;; temporarily removed until Matthew fixes whatever. + #; + (hash-table-put! requires + (syntax->datum (syntax lang)) + (cons (syntax lang) + (hash-table-get requires + (syntax->datum (syntax lang)) + (λ () '())))) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace user-directory) new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ...)))))]))]) + (for-each (lambda (spec) + (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [else + (at-phase (list #f spec) requires)])) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) + + ;; jump-to : syntax -> void + (define (jump-to stx) + (let ([src (find-source-editor stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src set-position (- pos 1) (+ pos span -1))))) + + + ;; annotate-require-open : namespace string -> (stx -> void) + ;; relies on current-module-name-resolver, which in turn depends on + ;; current-directory and current-namespace + (define (annotate-require-open user-namespace user-directory) + (λ (require-spec) + (when (syntax-original? require-spec) + (let ([source (find-source-editor require-spec)]) + (when (and (is-a? source text%) + (syntax-position require-spec) + (syntax-span require-spec)) + (let ([defs-text (get-defs-text)]) + (when defs-text + (let* ([start (- (syntax-position require-spec) 1)] + [end (+ start (syntax-span require-spec))] + [file (get-require-filename (syntax->datum require-spec) + user-namespace + user-directory)]) + (when file + (send defs-text syncheck:add-menu + source + start end + #f + (make-require-open-menu file))))))))))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + (define (add-tail-ht-links tail-ht) + (hash-table-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) + stx-tos)))) + + ;; add-tail-ht-link : syntax syntax -> void + (define (add-tail-ht-link from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (when (and to-src from-src defs-text) + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (when (and from-pos to-pos) + (send defs-text syncheck:add-tail-arrow + from-src (- from-pos 1) + to-src (- to-pos 1))))))) + + ;; find-source : definitions-text source -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))))) + + ;; get-defs-text : -> text or false + (define (get-defs-text) + (let ([drs-frame (currently-processing-drscheme-frame)]) + (and drs-frame + (send drs-frame get-definitions-text)))) + + + + + ;; record-renamable-var : rename-ht syntax -> void + (define (record-renamable-var rename-ht stx) + (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) + (hash-table-put! rename-ht + key + (cons stx (hash-table-get rename-ht key (λ () '())))))) + + + ;; connect-identifier : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; (listof id-set) + ;; namespace + ;; directory + ;; boolean + ;; -> void + ;; adds arrows and rename menus for binders/bindings + (define (connect-identifier var rename-ht all-binders unused requires get-binding user-namespace user-directory actual?) + (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (when (and actual? (get-ids all-binders var)) + (record-renamable-var rename-ht var))) + + ;; connect-identifier/arrow : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; boolean + ;; -> void + ;; adds the arrows that correspond to binders/bindings + (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (let ([binders (get-ids all-binders var)]) + (when binders + (for-each (λ (x) + (when (syntax-original? x) + (connect-syntaxes x var actual?))) + binders)) + + (when (and unused requires) + (let ([req-path/pr (get-module-req-path (get-binding var))]) + (when req-path/pr + (let* ([req-path (car req-path/pr)] + [id (cdr req-path/pr)] + [req-stxes (hash-table-get requires req-path (λ () #f))]) + (when req-stxes + (hash-table-remove! unused req-path) + (for-each (λ (req-stx) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (add-jump-to-definition + var + id + (get-require-filename req-path user-namespace user-directory))) + (add-mouse-over var (fw:gui-utils:format-literal-label (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes req-stx var actual?))) + req-stxes)))))))) + + (define (id/require-match? var id req-stx) + (cond + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix)) + (let ([prefix (list-ref req-stx 1)]) + (equal? (format "~a~a" prefix id) + (symbol->string var)))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix-all-except)) + (let ([prefix (list-ref req-stx 1)]) + (and (not (memq id (cdddr req-stx))) + (equal? (format "~a~a" prefix id) + (symbol->string var))))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'rename)) + (eq? (list-ref req-stx 2) + var)] + [else (eq? var id)])) + + + ;; color/connect-top : namespace directory id-set syntax -> void + (define (color/connect-top rename-ht user-namespace user-directory binders var) + (let ([top-bound? + (or (get-ids binders var) + (parameterize ([current-namespace user-namespace]) + (let/ec k + (namespace-variable-value (syntax-e var) #t (λ () (k #f))) + #t)))]) + (if top-bound? + (color var lexically-bound-variable-style-name) + (color var error-style-name)) + (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + + + ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void + (define (color-unused requires unused) + (hash-table-for-each + unused + (λ (k v) + (for-each (λ (stx) (color stx error-style-name)) + (hash-table-get requires k))))) + + + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void + (define (make-rename-menu stxs id-sets) + (let ([defs-frame (currently-processing-drscheme-frame)]) + (when defs-frame + (let* ([defs-text (send defs-frame get-definitions-text)] + [source (syntax-source (car stxs))]) ;; all stxs in the list must have the same source + (when (and (send defs-text port-name-matches? source) + (send defs-text port-name-matches? source)) + (let* ([name-to-offer (format "~a" (syntax->datum (car stxs)))] + [start (- (syntax-position (car stxs)) 1)] + [fin (+ start (syntax-span (car stxs)))]) + (send defs-text syncheck:add-menu + defs-text + start + fin + (syntax-e (car stxs)) + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) + (callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback name-to-offer + defs-text + stxs + id-sets + frame-parent))))))))))))) + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (listof syntax[original]) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (let ([new-sym (format "~s" (string->symbol new-str))]) + (let* ([to-be-renamed + (remove-duplicates + (sort + (apply + append + (map (λ (id-set) + (apply + append + (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) + id-sets)) + (λ (x y) + ((syntax-position x) . >= . (syntax-position y)))))] + [do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))]) + (when do-renaming? + (unless (null? to-be-renamed) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source (syntax-source stx)]) + (when (send defs-text port-name-matches? source) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send defs-text delete start end #f) + (send defs-text insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (send defs-text end-edit-sequence)))))))) + + ;; get-require-filename : sexp namespace string[directory] -> filename + ;; finds the filename corresponding to the require in stx + (define (get-require-filename datum user-namespace user-directory) + (let ([mp + (parameterize ([current-namespace user-namespace] + [current-directory user-directory] + [current-load-relative-directory user-directory]) + (with-handlers ([exn:fail? (λ (x) #f)]) + ((current-module-name-resolver) datum #f #f)))]) + (and (resolved-module-path? mp) + (resolved-module-path-name mp)))) + + + ;; make-require-open-menu : path -> menu -> void + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/color.ss b/collects/drscheme/syncheck/color.ss new file mode 100644 index 0000000000..a1c6ef45a9 --- /dev/null +++ b/collects/drscheme/syncheck/color.ss @@ -0,0 +1,84 @@ +#lang scheme/base + +(require string-constants/string-constant + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/bitmap-label + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred/mred + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base) + "extra-stxcase.ss" + "id-sets.ss" + "extra-typed.ss") +;; color : syntax[original] str -> void +;; colors the syntax with style-name's style +(define (color stx style-name) + (let ([source (find-source-editor stx)]) + (when (is-a? source text%) + (let ([pos (- (syntax-position stx) 1)] + [span (syntax-span stx)]) + (color-range source pos (+ pos span) style-name))))) + +;; color-range : text start finish style-name +;; colors a range in the text based on `style-name' +(define (color-range source start finish style-name) + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (add-to-cleanup-texts source) + (send source change-style style start finish #f))) + + ;; find-source : definitions-text source -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))))) + +;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void + (define (add-to-cleanup-texts ed) + (let ([ed (find-outermost-editor ed)]) + (when (is-a? ed drscheme:unit:definitions-text<%>) + (let ([tab (send ed get-tab)]) + (send tab syncheck:add-to-cleanup-texts ed))))) + + ;; get-defs-text : -> text or false + (define (get-defs-text) + (let ([drs-frame (currently-processing-drscheme-frame)]) + (and drs-frame + (send drs-frame get-definitions-text)))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-stxcase.ss b/collects/drscheme/syncheck/extra-stxcase.ss new file mode 100644 index 0000000000..d5ac6927cc --- /dev/null +++ b/collects/drscheme/syncheck/extra-stxcase.ss @@ -0,0 +1,44 @@ +#lang scheme/base + +(require (only-in "extra-typed.ss" symbolic-compare?)) + +(provide (all-defined-out)) + +;; FIXME: handle for-template and for-label +;; extract-provided-vars : syntax -> (listof syntax[identifier]) +(define (extract-provided-vars stx) + (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? + [identifier + (identifier? (syntax identifier)) + (list (syntax identifier))] + + [(rename local-identifier export-identifier) + (list (syntax local-identifier))] + + ;; why do I even see this?!? + [(struct struct-identifier (field-identifier ...)) + null] + + [(all-from module-name) null] + [(all-from-except module-name identifier ...) + null] + [(all-defined-except identifier ...) + (syntax->list #'(identifier ...))] + [_ + null])) + + +;; trim-require-prefix : syntax -> syntax +(define (trim-require-prefix require-spec) + (syntax-case* require-spec (only prefix all-except prefix-all-except rename) symbolic-compare? + [(only module-name identifer ...) + (syntax module-name)] + [(prefix identifier module-name) + (syntax module-name)] + [(all-except module-name identifer ...) + (syntax module-name)] + [(prefix-all-except module-name identifer ...) + (syntax module-name)] + [(rename module-name local-identifer exported-identifer) + (syntax module-name)] + [_ require-spec])) \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra-typed.ss b/collects/drscheme/syncheck/extra-typed.ss new file mode 100644 index 0000000000..06f129af52 --- /dev/null +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -0,0 +1,453 @@ +#lang typed-scheme + +(require (except-in scheme/list remove-duplicates) + "id-sets.ss") + +(define-type-alias (MaybeList a) (Rec x (U a '() (Pair a x)))) + +(provide (all-defined-out)) + +;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) +;; removes duplicates, based on the source locations of the identifiers +;; assumes the list is ordered by source location +(: remove-duplicates ((Listof Syntax) -> (Listof Syntax))) +(define (remove-duplicates ids) + (cond + [(null? ids) null] + [else (let: loop : (Listof Syntax) + ([fst : Syntax (car ids)] + [rst : (Listof Syntax) (cdr ids)]) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + ;; CHANGE - used eqv? instead of =, since these might be #f + (eqv? (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) + + +;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean +;; returns #t if the name chosen would be the same as another name in this scope. +(: name-duplication? ((Listof Identifier) (Listof Id-Set) String -> Any)) +(define (name-duplication? to-be-renamed id-sets new-str) + (let ([new-ids (map (λ: ([id : Identifier]) (datum->syntax id (string->symbol new-str))) + to-be-renamed)]) + (ormap (λ: ([id-set : Id-Set]) + (ormap (λ: ([new-id : Identifier]) (get-ids id-set new-id)) + new-ids)) + id-sets))) + + +;; annotate-raw-keyword : syntax id-map -> void +;; annotates keywords when they were never expanded. eg. +;; if someone just types `(λ (x) x)' it has no 'origin +;; field, but there still are keywords. +(: annotate-raw-keyword (Syntax Id-Set -> Any)) +(define (annotate-raw-keyword stx id-map) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) + + +;; add-binders : syntax id-set -> void +;; transforms an argument list into a bunch of symbols/symbols +;; and puts them into the id-set +;; effect: colors the identifiers +(: add-binders (Syntax Id-Set -> Void)) +(define (add-binders stx id-set) + (let: loop : Void ([stx : (MaybeList Syntax) stx]) + (let ([e (if (syntax? stx) (syntax-e stx) stx)]) + (cond + [(cons? e) + (let ([fst (car e)] + [rst (cdr e)]) + (if (identifier? fst) ;; CHANGE - was (syntax? fst) + (begin + (when (syntax-original? fst) + (add-id id-set fst)) + (loop rst)) + (loop rst)))] + [(null? e) (void)] + [(identifier? stx) ;; CHANGE -- used to be else + (when (syntax-original? stx) + (add-id id-set stx))])))) + +(define-type-alias TailHT (HashTable Syntax (Listof Syntax))) + +;; annotate-tail-position/last : (listof syntax) -> void +(: annotate-tail-position/last (Syntax (Listof Syntax) TailHT -> Void)) +(define (annotate-tail-position/last orig-stx stxs tail-ht) + (unless (null? stxs) + (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + +;; annotate-tail-position : syntax -> void +;; colors the parens (if any) around the argument +;; to indicate this is a tail call. +(: annotate-tail-position (Syntax Syntax TailHT -> Void)) +(define (annotate-tail-position orig-stx tail-stx tail-ht) + (hash-set! + tail-ht + orig-stx + (cons + tail-stx + (hash-ref + tail-ht + orig-stx + (λ () null))))) + +;; add-disappeared-uses : syntax id-set -> void +(: add-disappeared-uses (Syntax Id-Set -> Void)) +(define (add-disappeared-uses stx id-set) + (let ([prop (syntax-property stx 'disappeared-use)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-id id-set prop)]))))) + +;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] +;; -> require-spec +;; syntax +;; -> void +(: add-require-spec ((HashTable Any (Listof Syntax)) -> (Syntax Syntax -> Void))) +(define (add-require-spec require-ht) + (λ (raw-spec syntax) + (when (syntax-original? syntax) + (let ([key (syntax->datum raw-spec)]) + (hash-set! require-ht + key + (cons syntax + (hash-ref require-ht + key + (λ () '())))))))) + +;; possible-suffixes : (listof string) +;; these are the suffixes that are checked for the reverse +;; module-path mapping. +(: possible-suffixes (Listof String)) +(define possible-suffixes '(".ss" ".scm" "")) + +;; add-origins : sexp id-set -> void +(: add-origins (Syntax Id-Set -> Void)) +(define (add-origins sexp id-set) + (let ([origin (syntax-property sexp 'origin)]) + (when (syntax? origin) ;; CHANGE - was (when origin ...) + (let loop ([ct origin]) + (cond + [(pair? ct) + (loop (car ct)) + (loop (cdr ct))] + [(identifier? ct) ;; CHANGE - was (syntax? ct) + (when (syntax-original? ct) + (add-id id-set ct))] + [else (void)]))))) + + +;; add-disappeared-bindings : syntax id-set -> void +(: add-disappeared-bindings (Syntax Id-Set Id-Set -> Void)) +(define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + +;; module-name-sym->filename : symbol -> (union #f string) +(: module-name-sym->filename (Symbol -> (Option Path))) +(define (module-name-sym->filename sym) + (let ([str (symbol->string sym)]) + (and ((string-length str) . > . 1) + (char=? (string-ref str 0) #\,) + (let ([fn (substring str 1 (string-length str))]) + (ormap (λ: ([x : String]) + (let ([test (string->path (string-append fn x))]) + (and (file-exists? test) + test))) + possible-suffixes))))) + +(: symbolic-compare? (Syntax Syntax -> Boolean)) +(define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) + +;; type req/tag = (make-req/tag syntax sexp boolean) +(define-typed-struct req/tag ([req-stx : Syntax] [req-sexp : Any] [used? : Boolean])) + +;; add-var : hash-table -> syntax -> void +;; adds the variable to the hash table. +(: add-var ((HashTable Any (Listof Any)) -> (Syntax -> Void))) +(define (add-var ht) + (λ (var) + (let* ([key (syntax-e var)] + [prev (hash-ref ht #{key :: Any} (λ () #{null :: (Listof Any)}))]) + (hash-set! ht #{key :: Any} #{(cons var prev) :: (Listof Any)})))) + + + +#| +;; annotate-basic : syntax +;; namespace +;; string[directory] +;; syntax[id] +;; id-set (six of them) +;; hash-table[require-spec -> syntax] (three of them) +;; -> void +(: annotate-basic (Syntax + Any String Syntax + Id-Set Id-Set Id-Set Id-Set Id-Set Id-Set + Any + (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) (HashTable Syntax Syntax) + -> Void)) +(define (annotate-basic sexp user-namespace user-directory jump-to-id + low-binders high-binders + low-varrefs high-varrefs + low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (let ([tail-ht (make-hash-table)] + [maybe-jump + (λ: ([vars : Syntax]) + (when jump-to-id + (for-each (λ: ([id : Identifier]) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; 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)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + ;; temporarily removed until Matthew fixes whatever. + #; + (hash-table-put! requires + (syntax->datum (syntax lang)) + (cons (syntax lang) + (hash-table-get requires + (syntax->datum (syntax lang)) + (λ () '())))) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace user-directory) new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ...)))))]))]) + (for-each (lambda (spec) + (syntax-case* spec (for-syntax for-template for-label) (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [else + (at-phase (list #f spec) requires)])) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) +|# \ No newline at end of file diff --git a/collects/drscheme/syncheck/extra.ss b/collects/drscheme/syncheck/extra.ss new file mode 100644 index 0000000000..b541dbb395 --- /dev/null +++ b/collects/drscheme/syncheck/extra.ss @@ -0,0 +1,21 @@ +#lang scheme/base + + + + + + + + + + + + + + + + + + + + diff --git a/collects/drscheme/syncheck/id-sets.ss b/collects/drscheme/syncheck/id-sets.ss new file mode 100644 index 0000000000..fc2c720b25 --- /dev/null +++ b/collects/drscheme/syncheck/id-sets.ss @@ -0,0 +1,41 @@ +#lang typed-scheme + +(provide (rename-out [make-module-identifier-mapping make-id-set] + [module-identifier-mapping? id-set?]) + add-id get-idss get-ids for-each-ids + Id-Set) + +(require/opaque-type Id-Set module-identifier-mapping? syntax/boundmap) + +;; FIXME - need polymorphic imports +(require/typed [module-identifier-mapping-get module-identifier-mapping-get/f] + (Id-Set Identifier (-> #f) -> (U (Listof Identifier) #f)) + syntax/boundmap) + +(require/typed syntax/boundmap + [make-module-identifier-mapping (-> Id-Set)] + [module-identifier-mapping-get + (Id-Set Identifier (-> '()) -> (Listof Identifier))] + [module-identifier-mapping-put! (Id-Set Identifier (Listof Identifier) -> Void)] + [module-identifier-mapping-for-each (Id-Set (Identifier (Listof Identifier) -> Void) -> Void)] + [module-identifier-mapping-map + (Id-Set (Identifier (Listof Identifier) -> (Listof Identifier)) -> (Listof (Listof Identifier)))]) + + +(: add-id (Id-Set Identifier -> Void)) +(define (add-id mapping id) + (let* ([old (module-identifier-mapping-get mapping id (λ () '()))] + [new (cons id old)]) + (module-identifier-mapping-put! mapping id new))) + +(: get-idss (Id-Set -> (Listof (Listof Identifier)))) +(define (get-idss mapping) + (module-identifier-mapping-map mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) y))) + +(: get-ids (Id-Set Identifier -> (U (Listof Identifier) #f))) +(define (get-ids mapping var) + (module-identifier-mapping-get/f mapping var (λ () #f))) + +(: for-each-ids (Id-Set ((Listof Identifier) -> Void) -> Void)) +(define (for-each-ids mapping f) + (module-identifier-mapping-for-each mapping (λ: ([x : Identifier] [y : (Listof Identifier)]) (f y)))) diff --git a/collects/drscheme/syncheck/make-traversal.ss b/collects/drscheme/syncheck/make-traversal.ss new file mode 100644 index 0000000000..efe7dd3dff --- /dev/null +++ b/collects/drscheme/syncheck/make-traversal.ss @@ -0,0 +1,86 @@ +#lang scheme/base + +(require "id-sets.ss" + "annotate.ss") + +;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) +;; (namespace string[directory] -> void)) +;; returns a pair of functions that close over some state that +;; represents the top-level of a single program. The first value +;; is called once for each top-level expression and the second +;; value is called once, after all expansion is complete. +(define (make-traversal) + (let* ([tl-low-binders (make-id-set)] + [tl-high-binders (make-id-set)] + [tl-low-varrefs (make-id-set)] + [tl-high-varrefs (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] + [tl-templrefs (make-id-set)] + [tl-requires (make-hash-table 'equal)] + [tl-require-for-syntaxes (make-hash-table 'equal)] + [tl-require-for-templates (make-hash-table 'equal)] + [tl-require-for-labels (make-hash-table 'equal)] + [expanded-expression + (λ (user-namespace user-directory sexp jump-to-id) + (parameterize ([current-load-relative-directory user-directory]) + (let ([is-module? (syntax-case sexp (module) + [(module . rest) #t] + [else #f])]) + (cond + [is-module? + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] + [varrefs (make-id-set)] + [high-varrefs (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] + [templrefs (make-id-set)] + [requires (make-hash-table 'equal)] + [require-for-syntaxes (make-hash-table 'equal)] + [require-for-templates (make-hash-table 'equal)] + [require-for-labels (make-hash-table 'equal)]) + (annotate-basic sexp user-namespace user-directory jump-to-id + low-binders high-binders varrefs high-varrefs low-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (annotate-variables user-namespace + user-directory + low-binders + high-binders + varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels))] + [else + (annotate-basic sexp user-namespace user-directory jump-to-id + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)]))))] + [expansion-completed + (λ (user-namespace user-directory) + (parameterize ([current-load-relative-directory user-directory]) + (annotate-variables user-namespace + user-directory + tl-low-binders + tl-high-binders + tl-low-varrefs + tl-high-varrefs + tl-low-tops + tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)))]) + (values expanded-expression expansion-completed))) \ No newline at end of file diff --git a/collects/drscheme/syncheck/syncheck.ss b/collects/drscheme/syncheck/syncheck.ss new file mode 100644 index 0000000000..0e5055440d --- /dev/null +++ b/collects/drscheme/syncheck/syncheck.ss @@ -0,0 +1,2755 @@ +#lang scheme/base +#| + +Check Syntax separates two classes of identifiers, +those bound in this file and those bound by require, +and uses identifier-binding and identifier-transformer-binding +to distinguish them. + +Variables come from 'origin, 'disappeared-use, and 'disappeared-binding +syntax properties, as well as from variable references and binding (letrec-values, +let-values, define-values) in the fully expanded text. + +Variables inside #%top (not inside a module) are treated specially. +If the namespace has a binding for them, they are colored bound color. +If the namespace does not, they are colored the unbound color. + +|# + + +(require string-constants + scheme/unit + scheme/contract + scheme/class + drscheme/tool + mzlib/list + syntax/toplevel + syntax/boundmap + mrlib/switchable-button + (prefix-in drscheme:arrow: drscheme/arrow) + (prefix-in fw: framework/framework) + mred + framework + setup/xref + scribble/xref + scribble/manual-struct + net/url + net/uri-codec + browser/external + (for-syntax scheme/base)) +(provide tool@) + +(define o (current-output-port)) + +(define status-init (string-constant cs-status-init)) +(define status-coloring-program (string-constant cs-status-coloring-program)) +(define status-eval-compile-time (string-constant cs-status-eval-compile-time)) +(define status-expanding-expression (string-constant cs-status-expanding-expression)) +(define status-loading-docs-index (string-constant cs-status-loading-docs-index)) + +(define jump-to-next-bound-occurrence (string-constant cs-jump-to-next-bound-occurrence)) +(define jump-to-binding (string-constant cs-jump-to-binding)) +(define jump-to-definition (string-constant cs-jump-to-definition)) + +(define-local-member-name + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition + + syncheck:clear-highlighting + syncheck:button-callback + syncheck:add-to-cleanup-texts + ;syncheck:error-report-visible? ;; test suite uses this one. + ;syncheck:get-bindings-table ;; test suite uses this one. + syncheck:clear-error-message + + hide-error-report + get-error-report-text + get-error-report-visible? + + turn-off-error-report + turn-on-error-report + + update-button-visibility/settings) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + ;; use this to communicate the frame being + ;; syntax checked w/out having to add new + ;; parameters to all of the functions + (define currently-processing-definitions-text (make-parameter #f)) + + (define (phase1) + (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin)) + (define (phase2) (void)) + + (define (printf . args) (apply fprintf o args)) + + + (define xref 'not-yet-loaded-xref) + (define (get-xref) + (cond + [(equal? xref 'failed-to-load) #f] + [else + (when (symbol? xref) + (error 'get-xref "xref has not yet been loaded")) + xref])) + (define (force-xref th) + (cond + [(equal? xref 'failed-to-load) + (void)] + [(symbol? xref) + (th) + (with-handlers ((exn? (λ (exn) (set! xref 'failed-to-load)))) + (set! xref (load-collections-xref)))] + [else + (void)])) + + + + ;;; ;;; ;;; ;;;;; + ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; + ; ;; ; ; ; + ; ; ; ; ; + ; ; ;; ;; ; + ;;; ;;; ;;;;; + + + ;; used for quicker debugging of the preference panel + '(define test-preference-panel + (λ (name f) + (let ([frame (make-object frame% name)]) + (f frame) + (send frame show #t)))) + + (define-struct graphic (pos* locs->thunks draw-fn click-fn)) + + (define-struct arrow (start-x start-y end-x end-y) #:mutable) + (define-struct (var-arrow arrow) + (start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level)) ;; level is one of 'lexical, 'top-level, 'import + (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) + + ;; color : string + ;; text: text:basic<%> + ;; start, fin: number + ;; used to represent regions to highlight when passing the mouse over the syncheck window + (define-struct colored-region (color text start fin)) + + ;; id : symbol -- the nominal-source-id from identifier-binding + ;; filename : path + (define-struct def-link (id filename) #:inspector (make-inspector)) + + (define tacked-var-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)) + (define var-pen (send the-pen-list find-or-create-pen "BLUE" 1 'solid)) + + (define templ-color (send the-color-database find-color "purple")) + (define templ-pen (send the-pen-list find-or-create-pen templ-color 1 'solid)) + (define tacked-templ-brush (send the-brush-list find-or-create-brush templ-color 'solid)) + + (define tail-pen (send the-pen-list find-or-create-pen "orchid" 1 'solid)) + (define tacked-tail-brush (send the-brush-list find-or-create-brush "orchid" 'solid)) + (define untacked-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) + + (define syncheck-text<%> + (interface () + syncheck:init-arrows + syncheck:clear-arrows + syncheck:add-menu + syncheck:add-arrow + syncheck:add-tail-arrow + syncheck:add-mouse-over-status + syncheck:add-jump-to-definition + syncheck:sort-bindings-table + syncheck:get-bindings-table + syncheck:jump-to-next-bound-occurrence + syncheck:jump-to-binding-occurrence + syncheck:jump-to-definition)) + + ;; clearing-text-mixin : (mixin text%) + ;; overrides methods that make sure the arrows go away appropriately. + ;; adds a begin/end-edit-sequence to the insertion and deletion + ;; to ensure that the on-change method isn't called until after + ;; the arrows are cleared. + (define clearing-text-mixin + (mixin ((class->interface text%)) () + + (inherit begin-edit-sequence end-edit-sequence) + (define/augment (on-delete start len) + (begin-edit-sequence) + (inner (void) on-delete start len)) + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (clean-up) + (end-edit-sequence)) + + (define/augment (on-insert start len) + (begin-edit-sequence) + (inner (void) on-insert start len)) + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (clean-up) + (end-edit-sequence)) + + (define/private (clean-up) + (let ([st (find-syncheck-text this)]) + (when (and st + (is-a? st drscheme:unit:definitions-text<%>)) + (let ([tab (send st get-tab)]) + (send tab syncheck:clear-error-message) + (send tab syncheck:clear-highlighting))))) + + (super-new))) + + (define make-syncheck-text% + (λ (super%) + (let* ([cursor-arrow (make-object cursor% 'arrow)]) + (class* super% (syncheck-text<%>) + (inherit set-cursor get-admin invalidate-bitmap-cache set-position + get-pos/text position-location + get-canvas last-position dc-location-to-editor-location + find-position begin-edit-sequence end-edit-sequence + highlight-range unhighlight-range + paragraph-end-position first-line-currently-drawn-specially?) + + + + ;; arrow-vectors : + ;; (union + ;; #f + ;; (hash-table + ;; (text% + ;; . -o> . + ;; (vector (listof (union (cons (union #f sym) (menu -> void)) + ;; def-link + ;; tail-link + ;; arrow + ;; string)))))) + (define arrow-vectors #f) + + + ;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))] + ;; this is a private field + (define bindings-table (make-hash)) + + ;; add-to-bindings-table : text number number text number number -> boolean + ;; results indicates if the binding was added to the table. It is added, unless + ;; 1) it is already there, or + ;; 2) it is a link to itself + (define/private (add-to-bindings-table start-text start-left start-right + end-text end-left end-right) + (cond + [(and (object=? start-text end-text) + (= start-left end-left) + (= start-right end-right)) + #f] + [else + (let* ([key (list start-text start-left start-right)] + [priors (hash-ref bindings-table key (λ () '()))] + [new (list end-text end-left end-right)]) + (cond + [(member new priors) + #f] + [else + (hash-set! bindings-table key (cons new priors)) + #t]))])) + + ;; for use in the automatic test suite + (define/public (syncheck:get-bindings-table) bindings-table) + + (define/public (syncheck:sort-bindings-table) + + ;; compare-bindings : (list text number number) (list text number number) -> boolean + (define (compare-bindings l1 l2) + (let ([start-text (list-ref l1 0)] + [start-left (list-ref l1 1)] + [end-text (list-ref l2 0)] + [end-left (list-ref l2 1)]) + (let-values ([(sx sy) (find-dc-location start-text start-left)] + [(ex ey) (find-dc-location end-text end-left)]) + (cond + [(= sy ey) (< sx ex)] + [else (< sy ey)])))) + + ;; find-dc-location : text number -> (values number number) + (define (find-dc-location text pos) + (let ([bx (box 0)] + [by (box 0)]) + (send text position-location pos bx by) + (send text editor-location-to-dc-location (unbox bx) (unbox by)))) + + (hash-for-each + bindings-table + (λ (k v) + (hash-set! bindings-table k (sort v compare-bindings))))) + + (define tacked-hash-table (make-hasheq)) + (define cursor-location #f) + (define cursor-text #f) + (define cursor-eles #f) + + ;; find-char-box : text number number -> (values number number number number) + ;; returns the bounding box (left, top, right, bottom) for the text range. + ;; only works right if the text is on a single line. + (define/private (find-char-box text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values + xl + yl + xr + yr)))) + + (define/private (update-arrow-poss arrow) + (cond + [(var-arrow? arrow) (update-var-arrow-poss arrow)] + [(tail-arrow? arrow) (update-tail-arrow-poss arrow)])) + + (define/private (update-var-arrow-poss arrow) + (let-values ([(start-x start-y) (find-poss + (var-arrow-start-text arrow) + (var-arrow-start-pos-left arrow) + (var-arrow-start-pos-right arrow))] + [(end-x end-y) (find-poss + (var-arrow-end-text arrow) + (var-arrow-end-pos-left arrow) + (var-arrow-end-pos-right arrow))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + + (define/private (update-tail-arrow-poss arrow) + ;; If the item is an embedded editor snip, redirect + ;; the arrow to point at the left edge rather than the + ;; midpoint. + (define (find-poss/embedded text pos) + (let* ([snip (send text find-snip pos 'after)]) + (cond + [(and snip + (is-a? snip editor-snip%) + (= pos (send text get-snip-position snip))) + (find-poss text pos pos)] + [else + (find-poss text pos (+ pos 1))]))) + (let-values ([(start-x start-y) (find-poss/embedded + (tail-arrow-from-text arrow) + (tail-arrow-from-pos arrow))] + [(end-x end-y) (find-poss/embedded + (tail-arrow-to-text arrow) + (tail-arrow-to-pos arrow))]) + (set-arrow-start-x! arrow start-x) + (set-arrow-start-y! arrow start-y) + (set-arrow-end-x! arrow end-x) + (set-arrow-end-y! arrow end-y))) + + (define/private (find-poss text left-pos right-pos) + (let ([xlb (box 0)] + [ylb (box 0)] + [xrb (box 0)] + [yrb (box 0)]) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))] + [(xl yl) (dc-location-to-editor-location xl-off yl-off)] + [(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] + [(xr yr) (dc-location-to-editor-location xr-off yr-off)]) + (values (/ (+ xl xr) 2) + (/ (+ yl yr) 2))))) + + ;; syncheck:init-arrows : -> void + (define/public (syncheck:init-arrows) + (set! tacked-hash-table (make-hasheq)) + (set! arrow-vectors (make-hasheq)) + (set! bindings-table (make-hash)) + (let ([f (get-top-level-window)]) + (when f + (send f open-status-line 'drscheme:check-syntax:mouse-over)))) + + ;; syncheck:clear-arrows : -> void + (define/public (syncheck:clear-arrows) + (when (or arrow-vectors cursor-location cursor-text) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (set! tacked-hash-table #f) + (set! arrow-vectors #f) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (when any-tacked? + (invalidate-bitmap-cache)) + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f close-status-line 'drscheme:check-syntax:mouse-over)))))) + (define/public (syncheck:add-menu text start-pos end-pos key make-menu) + (when (and (<= 0 start-pos end-pos (last-position))) + (add-to-range/key text start-pos end-pos make-menu key #t))) + + (define/public (syncheck:add-background-color text color start fin key) + (when (is-a? text text:basic<%>) + (add-to-range/key text start fin (make-colored-region color text start fin) key #f))) + + ;; syncheck:add-arrow : symbol text number number text number number boolean -> void + ;; pre: start-editor, end-editor are embedded in `this' (or are `this') + (define/public (syncheck:add-arrow start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level) + (let* ([arrow (make-var-arrow #f #f #f #f + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right + actual? level)]) + (when (add-to-bindings-table + start-text start-pos-left start-pos-right + end-text end-pos-left end-pos-right) + (add-to-range/key start-text start-pos-left start-pos-right arrow #f #f) + (add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))) + + ;; syncheck:add-tail-arrow : text number text number -> void + (define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos) + (let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)]) + (add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f) + (add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))) + + ;; syncheck:add-jump-to-definition : text start end id filename -> void + (define/public (syncheck:add-jump-to-definition text start end id filename) + (add-to-range/key text start end (make-def-link id filename) #f #f)) + + ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void + (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) + (add-to-range/key text pos-left pos-right str #f #f)) + + ;; add-to-range/key : text number number any any boolean -> void + ;; adds `key' to the range `start' - `end' in the editor + ;; If use-key? is #t, it adds `to-add' with the key, and does not + ;; replace a value with that key already there. + ;; If use-key? is #f, it adds `to-add' without a key. + ;; pre: arrow-vectors is not #f + (define/private (add-to-range/key text start end to-add key use-key?) + (let ([arrow-vector (hash-ref + arrow-vectors + text + (λ () + (let ([new-vec + (make-vector + (add1 (send text last-position)) + null)]) + (hash-set! + arrow-vectors + text + new-vec) + new-vec)))]) + (let loop ([p start]) + (when (and (<= p end) + (< p (vector-length arrow-vector))) + ;; the last test in the above and is because some syntax objects + ;; appear to be from the original source, but can have bogus information. + + (let ([r (vector-ref arrow-vector p)]) + (cond + [use-key? + (unless (ormap (λ (x) + (and (pair? x) + (car x) + (eq? (car x) key))) + r) + (vector-set! arrow-vector p (cons (cons key to-add) r)))] + [else + (vector-set! arrow-vector p (cons to-add r))])) + (loop (add1 p)))))) + + (inherit get-top-level-window) + + (define/augment (on-change) + (inner (void) on-change) + (when arrow-vectors + (flush-arrow-coordinates-cache) + (let ([any-tacked? #f]) + (when tacked-hash-table + (let/ec k + (hash-for-each + tacked-hash-table + (λ (key val) + (set! any-tacked? #t) + (k (void)))))) + (when any-tacked? + (invalidate-bitmap-cache))))) + + ;; flush-arrow-coordinates-cache : -> void + ;; pre-condition: arrow-vector is not #f. + (define/private (flush-arrow-coordinates-cache) + (hash-for-each + arrow-vectors + (λ (text arrow-vector) + (let loop ([n (vector-length arrow-vector)]) + (unless (zero? n) + (let ([eles (vector-ref arrow-vector (- n 1))]) + (for-each (λ (ele) + (cond + [(arrow? ele) + (set-arrow-start-x! ele #f) + (set-arrow-start-y! ele #f) + (set-arrow-end-x! ele #f) + (set-arrow-end-y! ele #f)])) + eles)) + (loop (- n 1))))))) + + (define/override (on-paint before dc left top right bottom dx dy draw-caret) + (when (and arrow-vectors (not before)) + (let ([draw-arrow2 + (λ (arrow) + (unless (arrow-start-x arrow) + (update-arrow-poss arrow)) + (let ([start-x (arrow-start-x arrow)] + [start-y (arrow-start-y arrow)] + [end-x (arrow-end-x arrow)] + [end-y (arrow-end-y arrow)]) + (unless (and (= start-x end-x) + (= start-y end-y)) + (drscheme:arrow:draw-arrow dc start-x start-y end-x end-y dx dy) + (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow))) + (let-values ([(fw fh _d _v) (send dc get-text-extent "x")]) + (send dc draw-text "?" + (+ end-x dx fw) + (+ end-y dy (- fh))))))))] + [old-brush (send dc get-brush)] + [old-pen (send dc get-pen)] + [old-font (send dc get-font)] + [old-text-foreground (send dc get-text-foreground)] + [old-text-mode (send dc get-text-mode)]) + (send dc set-font + (send the-font-list find-or-create-font + (send old-font get-point-size) + 'default + 'normal + 'bold)) + (send dc set-text-foreground templ-color) + (hash-for-each tacked-hash-table + (λ (arrow v) + (when v + (cond + [(var-arrow? arrow) + (if (var-arrow-actual? arrow) + (begin (send dc set-pen var-pen) + (send dc set-brush tacked-var-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush tacked-templ-brush)))] + [(tail-arrow? arrow) + (send dc set-pen tail-pen) + (send dc set-brush tacked-tail-brush)]) + (draw-arrow2 arrow)))) + (when (and cursor-location + cursor-text) + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector cursor-location)]) + (for-each (λ (ele) + (cond + [(var-arrow? ele) + (if (var-arrow-actual? ele) + (begin (send dc set-pen var-pen) + (send dc set-brush untacked-brush)) + (begin (send dc set-pen templ-pen) + (send dc set-brush untacked-brush))) + (draw-arrow2 ele)] + [(tail-arrow? ele) + (send dc set-pen tail-pen) + (send dc set-brush untacked-brush) + (for-each-tail-arrows draw-arrow2 ele)])) + eles))))) + (send dc set-brush old-brush) + (send dc set-pen old-pen) + (send dc set-font old-font) + (send dc set-text-foreground old-text-foreground) + (send dc set-text-mode old-text-mode))) + + ;; do the drawing before calling super so that the arrows don't + ;; cross the "#lang ..." line, if it is present. + (super on-paint before dc left top right bottom dx dy draw-caret)) + + ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void + (define/private (for-each-tail-arrows f tail-arrow) + ;; call-f-ht ensures that `f' is only called once per arrow + (define call-f-ht (make-hasheq)) + + (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text + tail-arrow-other-pos tail-arrow-other-text) + + ;; traversal-ht ensures that we don't loop in the arrow traversal. + (let ([traversal-ht (make-hasheq)]) + (let loop ([tail-arrow tail-arrow]) + (unless (hash-ref traversal-ht tail-arrow (λ () #f)) + (hash-set! traversal-ht tail-arrow #t) + (unless (hash-ref call-f-ht tail-arrow (λ () #f)) + (hash-set! call-f-ht tail-arrow #t) + (f tail-arrow)) + (let* ([next-pos (tail-arrow-pos tail-arrow)] + [next-text (tail-arrow-text tail-arrow)] + [arrow-vector (hash-ref arrow-vectors next-text (λ () #f))]) + (when arrow-vector + (let ([eles (vector-ref arrow-vector next-pos)]) + (for-each (λ (ele) + (cond + [(tail-arrow? ele) + (let ([other-pos (tail-arrow-other-pos ele)] + [other-text (tail-arrow-other-text ele)]) + (when (and (= other-pos next-pos) + (eq? other-text next-text)) + (loop ele)))])) + eles)))))))) + + (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text + tail-arrow-from-pos tail-arrow-from-text) + (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text + tail-arrow-to-pos tail-arrow-to-text)) + + (define/override (on-event event) + (if arrow-vectors + (cond + [(send event leaving?) + (update-docs-background #f) + (when (and cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (invalidate-bitmap-cache)) + (super on-event event)] + [(or (send event moving?) + (send event entering?)) + (let-values ([(pos text) (get-pos/text event)]) + (cond + [(and pos (is-a? text text%)) + (unless (and (equal? pos cursor-location) + (eq? cursor-text text)) + (set! cursor-location pos) + (set! cursor-text text) + + (let* ([arrow-vector (hash-ref arrow-vectors cursor-text (λ () #f))] + [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) + + (unless (equal? cursor-eles eles) + (set! cursor-eles eles) + (update-docs-background eles) + (when eles + (update-status-line eles) + (for-each (λ (ele) + (cond + [(arrow? ele) + (update-arrow-poss ele)])) + eles) + (invalidate-bitmap-cache)))))] + [else + (update-docs-background #f) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f))) + (when (or cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #f) + (set! cursor-eles #f) + (invalidate-bitmap-cache))])) + (super on-event event)] + [(send event button-down? 'right) + (let-values ([(pos text) (get-pos/text event)]) + (if (and pos (is-a? text text%)) + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (vector-ref arrow-vector pos)] + [start-selection (send text get-start-position)] + [end-selection (send text get-end-position)]) + (cond + [(and (null? vec-ents) (= start-selection end-selection)) + (super on-event event)] + [else + (let* ([menu (make-object popup-menu% #f)] + [arrows (filter arrow? vec-ents)] + [def-links (filter def-link? vec-ents)] + [var-arrows (filter var-arrow? arrows)] + [add-menus (map cdr (filter pair? vec-ents))]) + (unless (null? arrows) + (make-object menu-item% + (string-constant cs-tack/untack-arrow) + menu + (λ (item evt) (tack/untack-callback arrows)))) + (unless (null? def-links) + (let ([def-link (car def-links)]) + (make-object menu-item% + jump-to-definition + menu + (λ (item evt) + (jump-to-definition-callback def-link))))) + (unless (null? var-arrows) + (make-object menu-item% + jump-to-next-bound-occurrence + menu + (λ (item evt) (jump-to-next-callback pos text arrows))) + (make-object menu-item% + jump-to-binding + menu + (λ (item evt) (jump-to-binding-callback arrows)))) + (unless (= start-selection end-selection) + (let ([arrows-menu + (make-object menu% + "Arrows crossing selection" + menu)] + [callback + (lambda (accept) + (tack-crossing-arrows-callback + arrow-vector + start-selection + end-selection + text + accept))]) + (make-object menu-item% + "Tack arrows" + arrows-menu + (lambda (item evt) + (callback + '(lexical top-level imported)))) + (make-object menu-item% + "Tack non-import arrows" + arrows-menu + (lambda (item evt) + (callback + '(lexical top-level)))) + (make-object menu-item% + "Untack arrows" + arrows-menu + (lambda (item evt) + (untack-crossing-arrows + arrow-vector + start-selection + end-selection))))) + (for-each (λ (f) (f menu)) add-menus) + (send (get-canvas) popup-menu menu + (+ 1 (inexact->exact (floor (send event get-x)))) + (+ 1 (inexact->exact (floor (send event get-y))))))])))) + (super on-event event)))] + [else (super on-event event)]) + (super on-event event))) + + (define/private (update-status-line eles) + (let ([has-txt? #f]) + (for-each (λ (ele) + (cond + [(string? ele) + (set! has-txt? #t) + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line + 'drscheme:check-syntax:mouse-over + ele)))])) + eles) + (unless has-txt? + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #f)))))) + + (define current-colored-region #f) + ;; update-docs-background : (or/c false/c (listof any)) -> void + (define/private (update-docs-background eles) + (let ([new-region (and eles (ormap (λ (x) (and (colored-region? x) x)) eles))]) + (unless (eq? current-colored-region new-region) + (when current-colored-region + (send (colored-region-text current-colored-region) unhighlight-range + (colored-region-start current-colored-region) + (colored-region-fin current-colored-region) + (send the-color-database find-color (colored-region-color current-colored-region)))) + (when new-region + (send (colored-region-text new-region) highlight-range + (colored-region-start new-region) + (colored-region-fin new-region) + (send the-color-database find-color (colored-region-color new-region)))) + (set! current-colored-region new-region)))) + + ;; tack/untack-callback : (listof arrow) -> void + ;; callback for the tack/untack menu item + (define/private (tack/untack-callback arrows) + (let ([arrow-tacked? + (λ (arrow) + (hash-ref + tacked-hash-table + arrow + (λ () #f)))] + [untack-arrows? #f]) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow)))) + arrow)])) + arrows) + (for-each + (λ (arrow) + (cond + [(var-arrow? arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) + (hash-set! tacked-hash-table arrow (not untack-arrows?))) + arrow)])) + arrows)) + (invalidate-bitmap-cache)) + + (define/private (tack-crossing-arrows-callback arrow-vector start end text kinds) + (define (xor a b) + (or (and a (not b)) (and (not a) b))) + (define (within t p) + (and (eq? t text) + (<= start p end))) + (for ([position (in-range start end)]) + (define things (vector-ref arrow-vector position)) + (for ([va things] #:when (var-arrow? va)) + (define va-start (var-arrow-start-pos-left va)) + (define va-start-text (var-arrow-start-text va)) + (define va-end (var-arrow-end-pos-left va)) + (define va-end-text (var-arrow-end-text va)) + (when (xor (within va-start-text va-start) + (within va-end-text va-end)) + (when (memq (var-arrow-level va) kinds) + (hash-set! tacked-hash-table va #t))))) + (invalidate-bitmap-cache)) + + (define/private (untack-crossing-arrows arrow-vector start end) + (for ([position (in-range start end)]) + (for ([va (vector-ref arrow-vector position)] #:when (var-arrow? va)) + (hash-set! tacked-hash-table va #f)))) + + ;; syncheck:jump-to-binding-occurrence : text -> void + ;; jumps to the next occurrence, based on the insertion point + (define/public (syncheck:jump-to-next-bound-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-next-callback pos text vec-ents)))) + + ;; syncheck:jump-to-binding-occurrence : text -> void + (define/public (syncheck:jump-to-binding-occurrence text) + (jump-to-binding/bound-helper + text + (λ (pos text vec-ents) + (jump-to-binding-callback vec-ents)))) + + (define/private (jump-to-binding/bound-helper text do-jump) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter var-arrow? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (do-jump pos text vec-ents)))))))) + + ;; jump-to-next-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-next-callback pos txt input-arrows) + (unless (null? input-arrows) + (let* ([arrow-key (car input-arrows)] + [orig-arrows (hash-ref bindings-table + (list (var-arrow-start-text arrow-key) + (var-arrow-start-pos-left arrow-key) + (var-arrow-start-pos-right arrow-key)) + (λ () '()))]) + (cond + [(null? orig-arrows) (void)] + [(null? (cdr orig-arrows)) (jump-to (car orig-arrows))] + [else + (let loop ([arrows orig-arrows]) + (cond + [(null? arrows) (jump-to (car orig-arrows))] + [else (let ([arrow (car arrows)]) + (cond + [(and (object=? txt (list-ref arrow 0)) + (<= (list-ref arrow 1) pos (list-ref arrow 2))) + (jump-to (if (null? (cdr arrows)) + (car orig-arrows) + (cadr arrows)))] + [else (loop (cdr arrows))]))]))])))) + + ;; jump-to : (list text number number) -> void + (define/private (jump-to to-arrow) + (let ([end-text (list-ref to-arrow 0)] + [end-pos-left (list-ref to-arrow 1)] + [end-pos-right (list-ref to-arrow 2)]) + (send end-text set-position end-pos-left end-pos-right) + (send end-text set-caret-owner #f 'global))) + + ;; jump-to-binding-callback : (listof arrow) -> void + ;; callback for the jump popup menu item + (define/private (jump-to-binding-callback arrows) + (unless (null? arrows) + (let* ([arrow (car arrows)] + [start-text (var-arrow-start-text arrow)] + [start-pos-left (var-arrow-start-pos-left arrow)] + [start-pos-right (var-arrow-start-pos-right arrow)]) + (send start-text set-position start-pos-left start-pos-right) + (send start-text set-caret-owner #f 'global)))) + + ;; syncheck:jump-to-definition : text -> void + (define/public (syncheck:jump-to-definition text) + (let ([pos (send text get-start-position)]) + (when arrow-vectors + (let ([arrow-vector (hash-ref arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (filter def-link? (vector-ref arrow-vector pos))]) + (unless (null? vec-ents) + (jump-to-definition-callback (car vec-ents))))))))) + + (define/private (jump-to-definition-callback def-link) + (let* ([filename (def-link-filename def-link)] + [id-from-def (def-link-id def-link)] + [frame (fw:handler:edit-file filename)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback id-from-def)))) + + (define/augment (after-set-next-settings settings) + (let ([frame (get-top-level-window)]) + (when frame + (send frame update-button-visibility/settings settings))) + (inner (void) after-set-next-settings settings)) + + (super-new))))) + + (define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask)) + + (define syncheck-frame<%> + (interface () + syncheck:button-callback + syncheck:error-report-visible?)) + + (define tab-mixin + + (mixin (drscheme:unit:tab<%>) () + (inherit is-current-tab? get-defs get-frame) + + (define report-error-text (new (fw:text:ports-mixin fw:scheme:text%))) + (define error-report-visible? #f) + (send report-error-text auto-wrap #t) + (send report-error-text set-autowrap-bitmap #f) + (send report-error-text lock #t) + + (define/public (get-error-report-text) report-error-text) + (define/public (get-error-report-visible?) error-report-visible?) + (define/public (turn-on-error-report) (set! error-report-visible? #t)) + (define/public (turn-off-error-report) (set! error-report-visible? #f)) + (define/augment (clear-annotations) + (inner (void) clear-annotations) + (syncheck:clear-error-message) + (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))) + + (define cleanup-texts '()) + (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) + (for-each (λ (text) + (send text thaw-colorer)) + cleanup-texts) + (set! cleanup-texts '()) + (send definitions lock locked?) + (send definitions end-edit-sequence))) + + (define/augment (can-close?) + (and (send report-error-text can-close?) + (inner #t can-close?))) + + (define/augment (on-close) + (send report-error-text on-close) + (send (get-defs) syncheck:clear-arrows) + (inner (void) on-close)) + + ;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void + (define/public (syncheck:add-to-cleanup-texts txt) + (unless (memq txt cleanup-texts) + (send txt freeze-colorer) + (set! cleanup-texts (cons txt cleanup-texts)))) + + (super-new))) + + (define unit-frame-mixin + (mixin (drscheme:unit:frame<%>) (syncheck-frame<%>) + + (inherit get-button-panel + get-definitions-canvas + get-definitions-text + get-interactions-text + get-current-tab) + + (define/augment (on-tab-change old-tab new-tab) + (inner (void) on-tab-change old-tab new-tab) + (if (send new-tab get-error-report-visible?) + (show-error-report) + (hide-error-report)) + (send report-error-canvas set-editor (send new-tab get-error-report-text)) + (update-button-visibility/tab new-tab)) + + (define/private (update-button-visibility/tab tab) + (update-button-visibility/settings (send (send tab get-defs) get-next-settings))) + (define/public (update-button-visibility/settings settings) + (let* ([lang (drscheme:language-configuration:language-settings-language settings)] + [visible? (send lang capability-value 'drscheme:check-syntax-button)]) + (send check-syntax-button-parent-panel change-children + (λ (l) + (if visible? + (list check-syntax-button) + '()))))) + + (define/augment (enable-evaluation) + (send check-syntax-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send check-syntax-button enable #f) + (inner (void) disable-evaluation)) + + (define report-error-parent-panel 'uninitialized-report-error-parent-panel) + (define report-error-panel 'uninitialized-report-error-panel) + (define report-error-canvas 'uninitialized-report-error-editor-canvas) + (define/override (get-definitions/interactions-panel-parent) + (set! report-error-parent-panel + (make-object vertical-panel% + (super get-definitions/interactions-panel-parent))) + (set! report-error-panel (instantiate horizontal-panel% () + (parent report-error-parent-panel) + (stretchable-height #f) + (alignment '(center center)) + (style '(border)))) + (send report-error-parent-panel change-children (λ (l) null)) + (let ([message-panel (instantiate vertical-panel% () + (parent report-error-panel) + (stretchable-width #f) + (stretchable-height #f) + (alignment '(left center)))]) + (make-object message% (string-constant check-syntax) message-panel) + (make-object message% (string-constant cs-error-message) message-panel)) + (set! report-error-canvas (new editor-canvas% + (parent report-error-panel) + (editor (send (get-current-tab) get-error-report-text)) + (line-count 3) + (style '(no-hscroll)))) + (instantiate button% () + (label (string-constant hide)) + (parent report-error-panel) + (callback (λ (x y) (hide-error-report))) + (stretchable-height #t)) + (make-object vertical-panel% report-error-parent-panel)) + + (define/public-final (syncheck:error-report-visible?) + (and (is-a? report-error-parent-panel area-container<%>) + (member report-error-panel (send report-error-parent-panel get-children)))) + + (define/public (hide-error-report) + (when (syncheck:error-report-visible?) + (send (get-current-tab) turn-off-error-report) + (send report-error-parent-panel change-children + (λ (l) (remq report-error-panel l))))) + + (define/private (show-error-report) + (unless (syncheck:error-report-visible?) + (send report-error-parent-panel change-children + (λ (l) (cons report-error-panel l))))) + + (define rest-panel 'uninitialized-root) + (define super-root 'uninitialized-super-root) + (define/override (make-root-area-container % parent) + (let* ([s-root (super make-root-area-container + vertical-panel% + parent)] + [r-root (make-object % s-root)]) + (set! super-root s-root) + (set! rest-panel r-root) + r-root)) + + (inherit open-status-line close-status-line update-status-line ensure-rep-hidden) + ;; syncheck:button-callback : (case-> (-> void) ((union #f syntax) -> void) + ;; this is the only function that has any code running on the user's thread + (define/public syncheck:button-callback + (case-lambda + [() (syncheck:button-callback #f)] + [(jump-to-id) + (when (send check-syntax-button is-enabled?) + (open-status-line 'drscheme:check-syntax) + (update-status-line 'drscheme:check-syntax status-init) + (ensure-rep-hidden) + (let-values ([(expanded-expression expansion-completed) (make-traversal)]) + (let* ([definitions-text (get-definitions-text)] + [interactions-text (get-interactions-text)] + [drs-eventspace (current-eventspace)] + [the-tab (get-current-tab)]) + (let-values ([(old-break-thread old-custodian) (send the-tab get-breakables)]) + (let* ([user-namespace #f] + [user-directory #f] + [user-custodian #f] + [normal-termination? #f] + + [show-error-report/tab + (λ () ; =drs= + (send the-tab turn-on-error-report) + (send (send the-tab get-error-report-text) scroll-to-position 0) + (when (eq? (get-current-tab) the-tab) + (show-error-report)))] + [cleanup + (λ () ; =drs= + (send the-tab set-breakables old-break-thread old-custodian) + (send the-tab enable-evaluation) + (send definitions-text end-edit-sequence) + (close-status-line 'drscheme:check-syntax) + + ;; do this with some lag ... not great, but should be okay. + (thread + (λ () + (flush-output (send (send the-tab get-error-report-text) get-err-port)) + (queue-callback + (λ () + (unless (= 0 (send (send the-tab get-error-report-text) last-position)) + (show-error-report/tab)))))))] + [kill-termination + (λ () + (unless normal-termination? + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian))))))] + [error-display-semaphore (make-semaphore 0)] + [uncaught-exception-raised + (λ () ;; =user= + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (yield error-display-semaphore) ;; let error display go first + (send the-tab syncheck:clear-highlighting) + (cleanup) + (custodian-shutdown-all user-custodian)))))] + [error-port (send (send the-tab get-error-report-text) get-err-port)] + [init-proc + (λ () ; =user= + (send the-tab set-breakables (current-thread) (current-custodian)) + (set-directory definitions-text) + (current-error-port error-port) + (error-display-handler + (λ (msg exn) ;; =user= + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + + ;; a call like this one also happens in + ;; drscheme:debug:error-display-handler/stacktrace + ;; but that call won't happen here, because + ;; the rep is not in the current-rep parameter + (send interactions-text highlight-errors/exn exn) + + (show-error-report/tab)))) + + (drscheme:debug:error-display-handler/stacktrace + msg + exn + '()) + + (semaphore-post error-display-semaphore))) + + (error-print-source-location #f) ; need to build code to render error first + (uncaught-exception-handler + (let ([oh (uncaught-exception-handler)]) + (λ (exn) + (uncaught-exception-raised) + (oh exn)))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (set! user-custodian (current-custodian)) + (set! user-directory (current-directory)) ;; set by set-directory above + (set! user-namespace (current-namespace)))]) + (send the-tab disable-evaluation) ;; this locks the editor, so must be outside. + (send definitions-text begin-edit-sequence #f) + (with-lock/edit-sequence + definitions-text + (λ () + (send the-tab clear-annotations) + (send the-tab reset-offer-kill) + (send (send the-tab get-defs) syncheck:init-arrows) + + (drscheme:eval:expand-program + (drscheme:language:make-text/pos definitions-text 0 (send definitions-text last-position)) + (send definitions-text get-next-settings) + #t + init-proc + kill-termination + (λ (sexp loop) ; =user= + (cond + [(eof-object? sexp) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (parameterize ([currently-processing-definitions-text definitions-text]) + (expansion-completed user-namespace user-directory) + (send definitions-text syncheck:sort-bindings-table)))) + (cleanup) + (custodian-shutdown-all user-custodian))))] + [else + (update-status-line 'drscheme:check-syntax status-eval-compile-time) + (eval-compile-time-part-of-top-level sexp) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ; =drs= + (with-lock/edit-sequence + definitions-text + (λ () + (open-status-line 'drscheme:check-syntax) + (force-xref (λ () (update-status-line 'drscheme:check-syntax status-loading-docs-index))) + (update-status-line 'drscheme:check-syntax status-coloring-program) + (parameterize ([currently-processing-definitions-text definitions-text]) + (expanded-expression user-namespace user-directory sexp jump-to-id)) + (close-status-line 'drscheme:check-syntax)))))) + (update-status-line 'drscheme:check-syntax status-expanding-expression) + (loop)]))))))))))])) + + ;; set-directory : text -> void + ;; sets the current-directory and current-load-relative-directory + ;; based on the file saved in the definitions-text + (define/private (set-directory definitions-text) + (let* ([tmp-b (box #f)] + [fn (send definitions-text get-filename tmp-b)]) + (unless (unbox tmp-b) + (when fn + (let-values ([(base name dir?) (split-path fn)]) + (current-directory base) + (current-load-relative-directory base)))))) + + ;; with-lock/edit-sequence : text (-> void) -> void + ;; sets and restores some state of the definitions text + ;; so that edits to the definitions text work out. + (define/private (with-lock/edit-sequence definitions-text thnk) + (let* ([locked? (send definitions-text is-locked?)]) + (send definitions-text begin-edit-sequence) + (send definitions-text lock #f) + (thnk) + (send definitions-text end-edit-sequence) + (send definitions-text lock locked?))) + + (super-new) + + (define check-syntax-button-parent-panel + (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f] + [stretchable-height #f])) + (define check-syntax-button + (new switchable-button% + (label (string-constant check-syntax)) + (bitmap syncheck-bitmap) + (parent check-syntax-button-parent-panel) + (callback (λ (button) (syncheck:button-callback))))) + (inherit register-toolbar-button) + (register-toolbar-button check-syntax-button) + (define/public (syncheck:get-button) check-syntax-button) + (send (get-button-panel) change-children + (λ (l) + (cons check-syntax-button-parent-panel + (remove check-syntax-button-parent-panel l)))) + (update-button-visibility/tab (get-current-tab)))) + + (define report-error-style (make-object style-delta% 'change-style 'italic)) + (send report-error-style set-delta-foreground "red") + + (define (add-check-syntax-key-bindings keymap) + (send keymap add-function + "check syntax" + (λ (obj evt) + (when (is-a? obj editor<%>) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (send frame syncheck:button-callback)))))))) + + (let ([jump-callback + (λ (send-msg) + (λ (obj evt) + (when (is-a? obj text%) + (let ([canvas (send obj get-canvas)]) + (when canvas + (let ([frame (send canvas get-top-level-window)]) + (when (is-a? frame syncheck-frame<%>) + (let ([defs (send frame get-definitions-text)]) + (when (is-a? defs syncheck-text<%>) + (send-msg defs obj))))))))))]) + (send keymap add-function + "jump to binding occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-binding-occurrence obj)))) + (send keymap add-function + "jump to next bound occurrence" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-next-bound-occurrence obj)))) + (send keymap add-function + "jump to definition (in other file)" + (jump-callback (λ (defs obj) (send defs syncheck:jump-to-definition obj))))) + + (send keymap map-function "f6" "check syntax") + (send keymap map-function "c:c;c:c" "check syntax") + (send keymap map-function "c:x;b" "jump to binding occurrence") + (send keymap map-function "c:x;n" "jump to next bound occurrence") + (send keymap map-function "c:x;d" "jump to definition (in other file)")) + + (define lexically-bound-variable-style-pref 'drscheme:check-syntax:lexically-bound) + (define imported-variable-style-pref 'drscheme:check-syntax:imported) + + (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 error-style-name (fw:scheme:short-sym->style-name 'error)) + ;(define constant-style-name (fw:scheme:short-sym->style-name 'constant)) + + (define (syncheck-add-to-preferences-panel parent) + (fw:color-prefs:build-color-selection-panel parent + lexically-bound-variable-style-pref + lexically-bound-variable-style-name + (string-constant cs-lexical-variable)) + (fw:color-prefs:build-color-selection-panel parent + imported-variable-style-pref + imported-variable-style-name + (string-constant cs-imported-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 imported-variable-style-pref + imported-variable-style-name + (make-object color% 68 0 203) + (make-object color% 166 0 255)) + + + + + + ; + ; + ; + ; ; + ; ; + ; ; ; ; + ; ;;; ; ; ; ;; ;;;; ;;; ; ; ;;;; ; ; ;;; ; ; ;;; ; ; ;;; ;;; ; ;;; + ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; + ; ;; ; ; ; ; ; ;;;; ; ; ; ;;;; ; ; ;;;;;; ; ;; ;;;; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ;; ;;;;; ; ; ;; ; ;;;;; ; ;;;; ; ;;; ;;;;; ; ;;; + ; ; + ; ; + ; ; + + + + ;; make-traversal : -> (values (namespace syntax (union #f syntax) -> void) + ;; (namespace string[directory] -> void)) + ;; returns a pair of functions that close over some state that + ;; represents the top-level of a single program. The first value + ;; is called once for each top-level expression and the second + ;; value is called once, after all expansion is complete. + (define (make-traversal) + (let* ([tl-low-binders (make-id-set)] + [tl-high-binders (make-id-set)] + [tl-low-varrefs (make-id-set)] + [tl-high-varrefs (make-id-set)] + [tl-low-tops (make-id-set)] + [tl-high-tops (make-id-set)] + [tl-templrefs (make-id-set)] + [tl-requires (make-hash)] + [tl-require-for-syntaxes (make-hash)] + [tl-require-for-templates (make-hash)] + [tl-require-for-labels (make-hash)] + [expanded-expression + (λ (user-namespace user-directory sexp jump-to-id) + (parameterize ([current-load-relative-directory user-directory]) + (let ([is-module? (syntax-case sexp (module) + [(module . rest) #t] + [else #f])]) + (cond + [is-module? + (let ([low-binders (make-id-set)] + [high-binders (make-id-set)] + [varrefs (make-id-set)] + [high-varrefs (make-id-set)] + [low-tops (make-id-set)] + [high-tops (make-id-set)] + [templrefs (make-id-set)] + [requires (make-hash)] + [require-for-syntaxes (make-hash)] + [require-for-templates (make-hash)] + [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 + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + (annotate-variables user-namespace + user-directory + low-binders + high-binders + varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels))] + [else + (annotate-basic sexp + user-namespace user-directory jump-to-id + tl-low-binders tl-high-binders + tl-low-varrefs tl-high-varrefs + tl-low-tops tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)]))))] + [expansion-completed + (λ (user-namespace user-directory) + (parameterize ([current-load-relative-directory user-directory]) + (annotate-variables user-namespace + user-directory + tl-low-binders + tl-high-binders + tl-low-varrefs + tl-high-varrefs + tl-low-tops + tl-high-tops + tl-templrefs + tl-requires + tl-require-for-syntaxes + tl-require-for-templates + tl-require-for-labels)))]) + (values expanded-expression expansion-completed))) + + + ;; type req/tag = (make-req/tag syntax sexp boolean) + (define-struct req/tag (req-stx req-sexp used?)) + + ;; annotate-basic : syntax + ;; namespace + ;; string[directory] + ;; syntax[id] + ;; id-set (six 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-tops high-tops + templrefs + requires require-for-syntaxes require-for-templates require-for-labels) + + (let ([tail-ht (make-hasheq)] + [maybe-jump + (λ (vars) + (when jump-to-id + (for-each (λ (id) + (let ([binding (identifier-binding id)]) + (when (pair? binding) + (let ([nominal-source-id (list-ref binding 3)]) + (when (eq? nominal-source-id jump-to-id) + (jump-to id)))))) + (syntax->list vars))))]) + + (let level-loop ([sexp sexp] + [high-level? #f]) + + (let* ([loop (λ (sexp) (level-loop sexp high-level?))] + [varrefs (if high-level? high-varrefs low-varrefs)] + [binders (if high-level? high-binders low-binders)] + [tops (if high-level? high-tops low-tops)] + [collect-general-info + (λ (stx) + (add-origins stx varrefs) + (add-disappeared-bindings stx binders varrefs) + (add-disappeared-uses stx varrefs))]) + (collect-general-info sexp) + (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! + quote quote-syntax with-continuation-mark + #%plain-app #%top #%plain-module-begin + define-values define-syntaxes define-values-for-syntax module + #%require #%provide #%expression) + (if high-level? free-transformer-identifier=? free-identifier=?) + [(#%plain-lambda args bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (add-binders (syntax args) binders) + (for-each loop (syntax->list (syntax (bodies ...)))))] + [(case-lambda [argss bodiess ...]...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each (λ (bodies/stx) (annotate-tail-position/last sexp + (syntax->list bodies/stx) + tail-ht)) + (syntax->list (syntax ((bodiess ...) ...)))) + (for-each + (λ (args bodies) + (add-binders args binders) + (for-each loop (syntax->list bodies))) + (syntax->list (syntax (argss ...))) + (syntax->list (syntax ((bodiess ...) ...)))))] + [(if test then else) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax then) tail-ht) + (annotate-tail-position sexp (syntax else) tail-ht) + (loop (syntax test)) + (loop (syntax else)) + (loop (syntax then)))] + [(begin bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position/last sexp (syntax->list (syntax (bodies ...))) tail-ht) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ;; treat a single body expression specially, since this has + ;; different tail behavior. + [(begin0 body) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax body) tail-ht) + (loop (syntax body)))] + + [(begin0 bodies ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + [(let-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(letrec-values (bindings ...) bs ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each collect-general-info (syntax->list (syntax (bindings ...)))) + (annotate-tail-position/last sexp (syntax->list (syntax (bs ...))) tail-ht) + (with-syntax ([(((xss ...) es) ...) (syntax (bindings ...))]) + (for-each (λ (x) (add-binders x binders)) + (syntax->list (syntax ((xss ...) ...)))) + (for-each loop (syntax->list (syntax (es ...)))) + (for-each loop (syntax->list (syntax (bs ...))))))] + [(set! var e) + (begin + (annotate-raw-keyword sexp varrefs) + + ;; 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)) + (if (identifier-binding (syntax var)) + (add-id varrefs (syntax var)) + (add-id tops (syntax var)))) + + (loop (syntax e)))] + [(quote datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs)] + [(quote-syntax datum) + ;(color-internal-structure (syntax datum) constant-style-name) + (annotate-raw-keyword sexp varrefs) + (let loop ([stx #'datum]) + (cond [(identifier? stx) + (when (syntax-original? stx) + (add-id templrefs stx))] + [(syntax? stx) + (loop (syntax-e stx))] + [(pair? stx) + (loop (car stx)) + (loop (cdr stx))] + [(vector? stx) + (for-each loop (vector->list stx))] + [(box? stx) + (loop (unbox stx))] + [else (void)]))] + [(with-continuation-mark a b c) + (begin + (annotate-raw-keyword sexp varrefs) + (annotate-tail-position sexp (syntax c) tail-ht) + (loop (syntax a)) + (loop (syntax b)) + (loop (syntax c)))] + [(#%plain-app pieces ...) + (begin + (annotate-raw-keyword sexp varrefs) + (for-each loop (syntax->list (syntax (pieces ...)))))] + [(#%top . var) + (begin + (annotate-raw-keyword sexp varrefs) + (when (syntax-original? (syntax var)) + (add-id tops (syntax var))))] + [(define-values vars b) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax vars) binders) + (maybe-jump (syntax vars)) + (loop (syntax b)))] + [(define-syntaxes names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(define-values-for-syntax names exp) + (begin + (annotate-raw-keyword sexp varrefs) + (add-binders (syntax names) high-binders) + (maybe-jump (syntax names)) + (level-loop (syntax exp) #t))] + [(module m-name lang (#%plain-module-begin bodies ...)) + (begin + (annotate-raw-keyword sexp varrefs) + ((annotate-require-open user-namespace user-directory) (syntax lang)) + + (hash-cons! requires (syntax->datum (syntax lang)) (syntax lang)) + (for-each loop (syntax->list (syntax (bodies ...)))))] + + ; top level or module top level only: + [(#%require require-specs ...) + (let ([at-phase + (lambda (stx requires) + (syntax-case stx () + [(_ require-specs ...) + (with-syntax ([((require-specs ...) ...) + (map (lambda (spec) + (syntax-case spec (just-meta) + [(just-meta m spec ...) + #'(spec ...)] + [else (list spec)])) + (syntax->list #'(require-specs ...)))]) + (let ([new-specs (map trim-require-prefix + (syntax->list (syntax (require-specs ... ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (annotate-require-open user-namespace + user-directory) + new-specs) + (for-each (add-require-spec requires) + new-specs + (syntax->list (syntax (require-specs ... ...))))))]))]) + (for-each (lambda (spec) + (let loop ([spec spec]) + (syntax-case* spec (for-syntax for-template for-label for-meta just-meta) + (lambda (a b) + (eq? (syntax-e a) (syntax-e b))) + [(just-meta phase specs ...) + (for-each loop (syntax->list #'(specs ...)))] + [(for-syntax specs ...) + (at-phase spec require-for-syntaxes)] + [(for-meta 1 specs ...) + (at-phase #'(for-syntax specs ...) require-for-syntaxes)] + [(for-template specs ...) + (at-phase spec require-for-templates)] + [(for-meta -1 specs ...) + (at-phase #'(for-template specs ...) require-for-templates)] + [(for-label specs ...) + (at-phase spec require-for-labels)] + [(for-meta #f specs ...) + (at-phase #'(for-label specs ...) require-for-labels)] + [(for-meta 0 specs ...) + (at-phase #'(for-run specs ...) requires)] + [(for-meta . _) (void)] + [else + (at-phase (list #f spec) requires)]))) + (syntax->list #'(require-specs ...))))] + + ; module top level only: + [(#%provide provide-specs ...) + (let ([provided-varss (map extract-provided-vars + (syntax->list (syntax (provide-specs ...))))]) + (annotate-raw-keyword sexp varrefs) + (for-each (λ (provided-vars) + (for-each + (λ (provided-var) + (when (syntax-original? provided-var) + (add-id varrefs provided-var))) + provided-vars)) + provided-varss))] + + [(#%expression arg) + (begin + (annotate-raw-keyword sexp varrefs) + (loop #'arg))] + [id + (identifier? (syntax id)) + (when (syntax-original? sexp) + (add-id varrefs sexp))] + [_ + (begin + #; + (printf "unknown stx: ~e datum: ~e source: ~e\n" + sexp + (and (syntax? sexp) + (syntax->datum sexp)) + (and (syntax? sexp) + (syntax-source sexp))) + (void))]))) + (add-tail-ht-links tail-ht))) + + (define (hash-cons! ht k v) + (hash-set! ht k (cons v (hash-ref ht k '())))) + + ;; add-disappeared-bindings : syntax id-set -> void + (define (add-disappeared-bindings stx binders disappaeared-uses) + (let ([prop (syntax-property stx 'disappeared-binding)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-origins prop disappaeared-uses) + (add-id binders prop)]))))) + + ;; add-disappeared-uses : syntax id-set -> void + (define (add-disappeared-uses stx id-set) + (let ([prop (syntax-property stx 'disappeared-use)]) + (when prop + (let loop ([prop prop]) + (cond + [(pair? prop) + (loop (car prop)) + (loop (cdr prop))] + [(identifier? prop) + (add-id id-set prop)]))))) + + ;; add-require-spec : hash-table[sexp[require-spec] -o> (listof syntax)] + ;; -> sexp[require-spec] + ;; syntax + ;; -> void + (define (add-require-spec require-ht) + (λ (raw-spec syntax) + (when (syntax-original? syntax) + (let ([key (syntax->datum raw-spec)]) + (hash-set! require-ht + key + (cons syntax + (hash-ref require-ht + key + (λ () '())))))))) + + ;; annotate-variables : namespace directory string id-set[four of them] (listof syntax) (listof syntax) -> void + ;; colors in and draws arrows for variables, according to their classifications + ;; in the various id-sets + (define (annotate-variables user-namespace + user-directory + low-binders + high-binders + low-varrefs + high-varrefs + low-tops + high-tops + templrefs + requires + require-for-syntaxes + require-for-templates + require-for-labels) + + (let ([rename-ht + ;; hash-table[(list source number number) -> (listof syntax)] + (make-hash)] + [unused-requires (make-hash)] + [unused-require-for-syntaxes (make-hash)] + [unused-require-for-templates (make-hash)] + [unused-require-for-labels (make-hash)] + ;; there is no define-for-template form, thus no for-template binders + [template-binders (make-id-set)] + [label-binders (make-id-set)] + [id-sets (list low-binders high-binders low-varrefs high-varrefs low-tops high-tops)]) + + (hash-for-each requires + (λ (k v) (hash-set! unused-requires k #t))) + (hash-for-each require-for-syntaxes + (λ (k v) (hash-set! unused-require-for-syntaxes k #t))) + (hash-for-each require-for-templates + (lambda (k v) (hash-set! unused-require-for-templates k #t))) + (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 identifier-binding) + (document-variable var identifier-binding) + (record-renamable-var rename-ht var))) + vars)) + (append (get-idss high-binders) + (get-idss low-binders))) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable var identifier-binding) + (document-variable var identifier-binding) + (connect-identifier var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss low-varrefs)) + + (for-each (λ (vars) (for-each + (λ (var) + (color-variable var identifier-transformer-binding) + (document-variable var identifier-transformer-binding) + (connect-identifier var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #t)) + vars)) + (get-idss high-varrefs)) + + (for-each (lambda (vars) (for-each + (lambda (var) + ;; no color variable + (connect-identifier var + rename-ht + low-binders + unused-requires + requires + identifier-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + high-binders + unused-require-for-syntaxes + require-for-syntaxes + identifier-transformer-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + template-binders ;; dummy; always empty + unused-require-for-templates + require-for-templates + identifier-template-binding + user-namespace + user-directory + #f) + (connect-identifier var + rename-ht + label-binders ;; dummy; always empty + unused-require-for-labels + require-for-labels + identifier-label-binding + user-namespace + user-directory + #f)) + vars)) + (get-idss templrefs)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top rename-ht user-namespace user-directory low-binders var)) + vars)) + (get-idss low-tops)) + + (for-each + (λ (vars) + (for-each + (λ (var) + (color/connect-top rename-ht user-namespace user-directory high-binders var)) + vars)) + (get-idss high-tops)) + + (color-unused require-for-labels unused-require-for-labels) + (color-unused require-for-templates unused-require-for-templates) + (color-unused require-for-syntaxes unused-require-for-syntaxes) + (color-unused requires unused-requires) + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) + + ;; record-renamable-var : rename-ht syntax -> void + (define (record-renamable-var rename-ht stx) + (let ([key (list (syntax-source stx) (syntax-position stx) (syntax-span stx))]) + (hash-set! rename-ht + key + (cons stx (hash-ref rename-ht key '()))))) + + ;; color-unused : hash-table[sexp -o> syntax] hash-table[sexp -o> #f] -> void + (define (color-unused requires unused) + (hash-for-each + unused + (λ (k v) + (for-each (λ (stx) (color stx error-style-name)) + (hash-ref requires k))))) + + ;; connect-identifier : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; (listof id-set) + ;; namespace + ;; directory + ;; boolean + ;; -> void + ;; adds arrows and rename menus for binders/bindings + (define (connect-identifier var rename-ht all-binders + unused requires get-binding user-namespace user-directory actual?) + (connect-identifier/arrow var all-binders + unused requires get-binding user-namespace user-directory actual?) + (when (and actual? (get-ids all-binders var)) + (record-renamable-var rename-ht var))) + + ;; id-level : identifier-binding-function identifier -> symbol + (define (id-level get-binding id) + (define (self-module? mpi) + (let-values ([(a b) (module-path-index-split mpi)]) + (and (not a) (not b)))) + (let ([binding (get-binding id)]) + (cond [(list? binding) + (if (self-module? (car binding)) + 'top-level + 'imported)] + [(eq? binding 'lexical) 'lexical] + [else 'top-level]))) + + ;; connect-identifier/arrow : syntax + ;; id-set + ;; (union #f hash-table) + ;; (union #f hash-table) + ;; (union identifier-binding identifier-transformer-binding) + ;; boolean + ;; -> void + ;; adds the arrows that correspond to binders/bindings + (define (connect-identifier/arrow var all-binders unused requires get-binding user-namespace user-directory actual?) + (let ([binders (get-ids all-binders var)]) + (when binders + (for-each (λ (x) + (when (syntax-original? x) + (connect-syntaxes x var actual? (id-level get-binding x)))) + binders)) + + (when (and unused requires) + (let ([req-path/pr (get-module-req-path (get-binding var))]) + (when req-path/pr + (let* ([req-path (car req-path/pr)] + [id (cdr req-path/pr)] + [req-stxes (hash-ref requires req-path (λ () #f))]) + (when req-stxes + (hash-remove! unused req-path) + (for-each (λ (req-stx) + (when (id/require-match? (syntax->datum var) + id + (syntax->datum req-stx)) + (when id + (add-jump-to-definition + var + id + (get-require-filename req-path user-namespace user-directory))) + (add-mouse-over var + (fw:gui-utils:format-literal-label + (string-constant cs-mouse-over-import) + (syntax-e var) + req-path)) + (connect-syntaxes req-stx var actual? + (id-level get-binding var)))) + req-stxes)))))))) + + (define (id/require-match? var id req-stx) + (cond + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix)) + (let ([prefix (list-ref req-stx 1)]) + (equal? (format "~a~a" prefix id) + (symbol->string var)))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'prefix-all-except)) + (let ([prefix (list-ref req-stx 1)]) + (and (not (memq id (cdddr req-stx))) + (equal? (format "~a~a" prefix id) + (symbol->string var))))] + [(and (pair? req-stx) + (eq? (list-ref req-stx 0) 'rename)) + (eq? (list-ref req-stx 2) + var)] + [else (eq? var id)])) + + + ;; get-module-req-path : binding -> (union #f (cons require-sexp sym)) + ;; argument is the result of identifier-binding or identifier-transformer-binding + (define (get-module-req-path binding) + (and (pair? binding) + (let ([mod-path (list-ref binding 2)]) + (cond + [(module-path-index? mod-path) + (let-values ([(base offset) (module-path-index-split mod-path)]) + (cons base (list-ref binding 3)))] + [(symbol? mod-path) + (cons mod-path (list-ref binding 3))])))) + + ;; color/connect-top : namespace directory id-set syntax -> void + (define (color/connect-top rename-ht user-namespace user-directory binders var) + (let ([top-bound? + (or (get-ids binders var) + (parameterize ([current-namespace user-namespace]) + (let/ec k + (namespace-variable-value (syntax-e var) #t (λ () (k #f))) + #t)))]) + (if top-bound? + (color var lexically-bound-variable-style-name) + (color var error-style-name)) + (connect-identifier var rename-ht binders #f #f identifier-binding user-namespace user-directory #t))) + + ;; color-variable : syntax (union identifier-binding identifier-transformer-binding) -> void + (define (color-variable var get-binding) + (let* ([b (get-binding var)] + [lexical? + (or (not b) + (eq? b 'lexical) + (and (pair? b) + (let ([path (caddr b)]) + (and (module-path-index? path) + (let-values ([(a b) (module-path-index-split path)]) + (and (not a) + (not b)))))))]) + (cond + [lexical? (color var lexically-bound-variable-style-name)] + [(pair? b) (color var imported-variable-style-name)]))) + + ;; add-var : hash-table -> syntax -> void + ;; adds the variable to the hash table. + (define (add-var ht) + (λ (var) + (let* ([key (syntax-e var)] + [prev (hash-ref ht key (λ () null))]) + (hash-set! ht key (cons var prev))))) + + ;; connect-syntaxes : syntax[original] syntax[original] boolean symbol -> void + ;; adds an arrow from `from' to `to', unless they have the same source loc. + (define (connect-syntaxes from to actual? level) + (let ([from-source (find-source-editor from)] + [to-source (find-source-editor to)] + [defs-text (get-defs-text)]) + (when (and from-source to-source defs-text) + (let ([pos-from (syntax-position from)] + [span-from (syntax-span from)] + [pos-to (syntax-position to)] + [span-to (syntax-span to)]) + (when (and pos-from span-from pos-to span-to) + (let* ([from-pos-left (- (syntax-position from) 1)] + [from-pos-right (+ from-pos-left (syntax-span from))] + [to-pos-left (- (syntax-position to) 1)] + [to-pos-right (+ to-pos-left (syntax-span to))]) + (unless (= from-pos-left to-pos-left) + (send defs-text syncheck:add-arrow + from-source from-pos-left from-pos-right + to-source to-pos-left to-pos-right + actual? level)))))))) + + ;; add-mouse-over : syntax[original] string -> void + ;; registers the range in the editor so that a mouse over + ;; this area shows up in the status line. + (define (add-mouse-over stx str) + (let* ([source (find-source-editor stx)] + [defs-text (get-defs-text)]) + (when (and defs-text + source + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-mouse-over-status + source pos-left pos-right str))))) + + ;; add-jump-to-definition : syntax symbol path -> void + ;; registers the range in the editor so that the + ;; popup menu in this area allows the programmer to jump + ;; to the definition of the id. + (define (add-jump-to-definition stx id filename) + (let ([source (find-source-editor stx)] + [defs-text (get-defs-text)]) + (when (and source + defs-text + (syntax-position stx) + (syntax-span stx)) + (let* ([pos-left (- (syntax-position stx) 1)] + [pos-right (+ pos-left (syntax-span stx))]) + (send defs-text syncheck:add-jump-to-definition + source + pos-left + pos-right + id + filename))))) + + ;; find-syncheck-text : text% -> (union #f (is-a?/c syncheck-text<%>)) + (define (find-syncheck-text text) + (let loop ([text text]) + (cond + [(is-a? text syncheck-text<%>) text] + [else + (let ([admin (send text get-admin)]) + (and (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-editor-snip (send admin get-snip)] + [editor-snip-admin (send enclosing-editor-snip get-admin)] + [enclosing-editor (send editor-snip-admin get-editor)]) + (loop enclosing-editor))))]))) + + ;; annotate-tail-position/last : (listof syntax) -> void + (define (annotate-tail-position/last orig-stx stxs tail-ht) + (unless (null? stxs) + (annotate-tail-position orig-stx (car (last-pair stxs)) tail-ht))) + + ;; annotate-tail-position : syntax -> void + ;; colors the parens (if any) around the argument + ;; to indicate this is a tail call. + (define (annotate-tail-position orig-stx tail-stx tail-ht) + (hash-set! + tail-ht + orig-stx + (cons + tail-stx + (hash-ref + tail-ht + orig-stx + (λ () null))))) + + ;; annotate-require-open : namespace string -> (stx -> void) + ;; relies on current-module-name-resolver, which in turn depends on + ;; current-directory and current-namespace + (define (annotate-require-open user-namespace user-directory) + (λ (require-spec) + (when (syntax-original? require-spec) + (let ([source (find-source-editor require-spec)]) + (when (and (is-a? source text%) + (syntax-position require-spec) + (syntax-span require-spec)) + (let ([defs-text (get-defs-text)]) + (when defs-text + (let* ([start (- (syntax-position require-spec) 1)] + [end (+ start (syntax-span require-spec))] + [file (get-require-filename (syntax->datum require-spec) + user-namespace + user-directory)]) + (when file + (send defs-text syncheck:add-menu + source + start end + #f + (make-require-open-menu file))))))))))) + + ;; get-require-filename : sexp namespace string[directory] -> filename + ;; finds the filename corresponding to the require in stx + (define (get-require-filename datum user-namespace user-directory) + (let ([mp + (parameterize ([current-namespace user-namespace] + [current-directory user-directory] + [current-load-relative-directory user-directory]) + (with-handlers ([exn:fail? (λ (x) #f)]) + ((current-module-name-resolver) datum #f #f)))]) + (and (resolved-module-path? mp) + (resolved-module-path-name mp)))) + + ;; make-require-open-menu : path -> menu -> void + (define (make-require-open-menu file) + (λ (menu) + (let-values ([(base name dir?) (split-path file)]) + (instantiate menu-item% () + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)))) + + ;; possible-suffixes : (listof string) + ;; these are the suffixes that are checked for the reverse + ;; module-path mapping. + (define possible-suffixes '(".ss" ".scm" "")) + + ;; module-name-sym->filename : symbol -> (union #f string) + (define (module-name-sym->filename sym) + (let ([str (symbol->string sym)]) + (and ((string-length str) . > . 1) + (char=? (string-ref str 0) #\,) + (let ([fn (substring str 1 (string-length str))]) + (ormap (λ (x) + (let ([test (string->path (string-append fn x))]) + (and (file-exists? test) + test))) + possible-suffixes))))) + + ;; add-origins : sexp id-set -> void + (define (add-origins sexp id-set) + (let ([origin (syntax-property sexp 'origin)]) + (when origin + (let loop ([ct origin]) + (cond + [(pair? ct) + (loop (car ct)) + (loop (cdr ct))] + [(syntax? ct) + (when (syntax-original? ct) + (add-id id-set ct))] + [else (void)]))))) + + ;; FIXME: handle for-template and for-label + ;; extract-provided-vars : syntax -> (listof syntax[identifier]) + (define (extract-provided-vars stx) + (syntax-case* stx (rename struct all-from all-from-except all-defined-except) symbolic-compare? + [identifier + (identifier? (syntax identifier)) + (list (syntax identifier))] + + [(rename local-identifier export-identifier) + (list (syntax local-identifier))] + + ;; why do I even see this?!? + [(struct struct-identifier (field-identifier ...)) + null] + + [(all-from module-name) null] + [(all-from-except module-name identifier ...) + null] + [(all-defined-except identifier ...) + (syntax->list #'(identifier ...))] + [_ + null])) + + + ;; trim-require-prefix : syntax -> syntax + (define (trim-require-prefix require-spec) + (syntax-case* require-spec (only prefix all-except prefix-all-except rename just-meta) symbolic-compare? + [(only module-name identifer ...) + (syntax module-name)] + [(prefix identifier module-name) + (syntax module-name)] + [(all-except module-name identifer ...) + (syntax module-name)] + [(prefix-all-except module-name identifer ...) + (syntax module-name)] + [(rename module-name local-identifer exported-identifer) + (syntax module-name)] + [_ require-spec])) + + (define (symbolic-compare? x y) (eq? (syntax-e x) (syntax-e y))) + + ;; add-binders : syntax id-set -> void + ;; transforms an argument list into a bunch of symbols/symbols + ;; and puts them into the id-set + ;; effect: colors the identifiers + (define (add-binders stx id-set) + (let loop ([stx stx]) + (let ([e (if (syntax? stx) (syntax-e stx) stx)]) + (cond + [(cons? e) + (let ([fst (car e)] + [rst (cdr e)]) + (if (syntax? fst) + (begin + (when (syntax-original? fst) + (add-id id-set fst)) + (loop rst)) + (loop rst)))] + [(null? e) (void)] + [else + (when (syntax-original? stx) + (add-id id-set stx))])))) + + ;; annotate-raw-keyword : syntax id-map -> void + ;; annotates keywords when they were never expanded. eg. + ;; if someone just types `(λ (x) x)' it has no 'origin + ;; field, but there still are keywords. + (define (annotate-raw-keyword stx id-map) + (let ([lst (syntax-e stx)]) + (when (pair? lst) + (let ([f-stx (car lst)]) + (when (and (syntax-original? f-stx) + (identifier? f-stx)) + (add-id id-map f-stx)))))) + + ;; color-internal-structure : syntax str -> void + (define (color-internal-structure stx style-name) + (let ([ht (make-hasheq)]) + ;; ht : stx -o> true + ;; indicates if we've seen this syntax object before + + (let loop ([stx stx] + [datum (syntax->datum stx)]) + (unless (hash-ref ht datum (λ () #f)) + (hash-set! ht datum #t) + (cond + [(pair? stx) + (loop (car stx) (car datum)) + (loop (cdr stx) (cdr datum))] + [(syntax? stx) + (when (syntax-original? stx) + (color stx style-name)) + (let ([stx-e (syntax-e stx)]) + (cond + [(cons? stx-e) + (loop (car stx-e) (car datum)) + (loop (cdr stx-e) (cdr datum))] + [(null? stx-e) + (void)] + [(vector? stx-e) + (for-each loop + (vector->list stx-e) + (vector->list datum))] + [(box? stx-e) + (loop (unbox stx-e) (unbox datum))] + [else (void)]))]))))) + + ;; jump-to : syntax -> void + (define (jump-to stx) + (let ([src (find-source-editor stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (when (and (is-a? src text%) + pos + span) + (send src set-position (- pos 1) (+ pos span -1))))) + + ;; color : syntax[original] str -> void + ;; colors the syntax with style-name's style + (define (color stx style-name) + (let ([source (find-source-editor stx)]) + (when (and (is-a? source text%) + (syntax-position stx) + (syntax-span stx)) + (let ([pos (- (syntax-position stx) 1)] + [span (syntax-span stx)]) + (color-range source pos (+ pos span) style-name))))) + + ;; color-range : text start finish style-name + ;; colors a range in the text based on `style-name' + (define (color-range source start finish style-name) + (let ([style (send (send source get-style-list) + find-named-style + style-name)]) + (add-to-cleanup-texts source) + (send source change-style style start finish #f))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + (define (add-tail-ht-links tail-ht) + (begin + (collapse-tail-links tail-ht) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each (λ (stx-to) (add-tail-ht-link stx-from stx-to)) + stx-tos))))) + + ;; hash-table[syntax -o> (listof syntax)] -> void + ;; take something like a transitive closure, except + ;; only when there are non-original links in between + + (define (collapse-tail-links tail-ht) + (let loop () + (let ([found-one? #f]) + (hash-for-each + tail-ht + (λ (stx-from stx-tos) + (for-each + (λ (stx-to) + (let ([stx-to-tos (hash-ref tail-ht stx-to '())]) + (for-each + (λ (stx-to-to) + (unless (and (add-tail-link? stx-from stx-to) + (add-tail-link? stx-to stx-to-to)) + (unless (memq stx-to-to (hash-ref tail-ht stx-from '())) + (set! found-one? #t) + (hash-cons! tail-ht stx-from stx-to-to)))) + stx-to-tos))) + stx-tos))) + + ;; this takes O(n^3) in general, so we just do + ;; one iteration. This doesn't work for case + ;; expressions but it seems to for most others. + ;; turning this on makes this function go from about + ;; 55 msec to about 2400 msec on my laptop, + ;; (a 43x slowdown) when checking the syntax of this file. + + #; + (when found-one? + (loop))))) + + ;; add-tail-ht-link : syntax syntax -> void + (define (add-tail-ht-link from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (when (and to-src from-src defs-text) + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (when (and from-pos to-pos) + (send defs-text syncheck:add-tail-arrow + from-src (- from-pos 1) + to-src (- to-pos 1))))))) + + ;; add-tail-link? : syntax syntax -> boolean + (define (add-tail-link? from-stx to-stx) + (let* ([to-src (find-source-editor to-stx)] + [from-src (find-source-editor from-stx)] + [defs-text (get-defs-text)]) + (and to-src from-src defs-text + (let ([from-pos (syntax-position from-stx)] + [to-pos (syntax-position to-stx)]) + (and from-pos to-pos))))) + + ;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void + (define (add-to-cleanup-texts ed) + (let ([ed (find-outermost-editor ed)]) + (when (is-a? ed drscheme:unit:definitions-text<%>) + (let ([tab (send ed get-tab)]) + (send tab syncheck:add-to-cleanup-texts ed))))) + + (define (find-outermost-editor ed) + (let loop ([ed ed]) + (let ([admin (send ed get-admin)]) + (if (is-a? admin editor-snip-editor-admin<%>) + (let* ([enclosing-snip (send admin get-snip)] + [enclosing-snip-admin (send enclosing-snip get-admin)]) + (loop (send enclosing-snip-admin get-editor))) + ed)))) + + ;; find-source-editor : stx -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (find-source-editor/defs stx defs-text)))) + + ;; find-source-editor : stx text -> editor or false + (define (find-source-editor/defs stx defs-text) + (cond + [(not (syntax-source stx)) #f] + [(and (symbol? (syntax-source stx)) + (text:lookup-port-name (syntax-source stx))) + => values] + [else + (let txt-loop ([text defs-text]) + (cond + [(and (is-a? text fw:text:basic<%>) + (send text port-name-matches? (syntax-source stx))) + text] + [else + (let snip-loop ([snip (send text find-first-snip)]) + (cond + [(not snip) + #f] + [(and (is-a? snip editor-snip%) + (send snip get-editor)) + (or (txt-loop (send snip get-editor)) + (snip-loop (send snip next)))] + [else + (snip-loop (send snip next))]))]))])) + ;; get-defs-text : -> text or false + (define (get-defs-text) + (currently-processing-definitions-text)) + + +; +; +; ; +; ; ; +; ; ; ; +; ;; ; ;;; ;;;; ; ; ; ;; ;; ;;; ; ;; ;;;;; ;;;; ;;;;; ;;; ;;; ; ;; +; ; ;; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ; ; ; ; ; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;;;; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; +; ;; ; ;;; ;;;; ;; ; ; ; ; ;;;; ; ; ;;; ;; ; ;;; ; ;;; ; ; +; +; +; + + + ;; document-variable : stx identifier-binding -> void + (define (document-variable stx get-binding) + (when (syntax-original? stx) + (let ([defs-text (currently-processing-definitions-text)]) + (when defs-text + (let ([binding-info (get-binding stx)]) + (when (and (pair? binding-info) + (syntax-position stx) + (syntax-span stx)) + (let* ([start (- (syntax-position stx) 1)] + [fin (+ start (syntax-span stx))] + [source-editor (find-source-editor stx)] + [xref (get-xref)]) + (when (and xref source-editor) + (let ([definition-tag (xref-binding->definition-tag xref binding-info #f)]) + (when definition-tag + (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) + (when path + (let ([index-entry (xref-tag->index-entry xref definition-tag)]) + (when index-entry + (send defs-text syncheck:add-background-color source-editor "navajowhite" start fin (syntax-e stx)) + (send defs-text syncheck:add-menu + source-editor + start + fin + (syntax-e stx) + (λ (menu) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry)))) + (callback + (λ (x y) + (let* ([url (path->url path)] + [url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)]) + (send-url (url->string url2)))))))))))))))))))))) + + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void + (define (make-rename-menu stxs id-sets) + (let ([defs-text (currently-processing-definitions-text)]) + (when defs-text + (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source + [source-editor (find-source-editor (car stxs))]) + (when (is-a? source-editor text%) + (let* ([start (- (syntax-position (car stxs)) 1)] + [fin (+ start (syntax-span (car stxs)))]) + (send defs-text syncheck:add-menu + source-editor + start + fin + (syntax-e (car stxs)) + (λ (menu) + (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) + (instantiate menu-item% () + (parent menu) + (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) + (callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback name-to-offer + defs-text + stxs + id-sets + frame-parent)))))))))))))) + + ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) + (define (find-menu-parent menu) + (let loop ([menu menu]) + (cond + [(is-a? menu menu-bar%) (send menu get-frame)] + [(is-a? menu popup-menu%) + (let ([target (send menu get-popup-target)]) + (cond + [(is-a? target editor<%>) + (let ([canvas (send target get-canvas)]) + (and canvas + (send canvas get-top-level-window)))] + [(is-a? target window<%>) + (send target get-top-level-window)] + [else #f]))] + [(is-a? menu menu-item<%>) (loop (send menu get-parent))] + [else #f]))) + + ;; rename-callback : string + ;; (and/c syncheck-text<%> definitions-text<%>) + ;; (listof syntax[original]) + ;; (listof id-set) + ;; (union #f (is-a?/c top-level-window<%>)) + ;; -> void + ;; callback for the rename popup menu item + (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (let ([new-str + (fw:keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant cs-rename-id) + (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) + parent + name-to-offer)))]) + (when new-str + (let* ([new-sym (format "~s" (string->symbol new-str))] + [to-be-renamed + (remove-duplicates + (sort + (apply + append + (map (λ (id-set) + (apply + append + (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) + id-sets)) + (λ (x y) + ((syntax-position x) . >= . (syntax-position y)))))] + [do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))]) + (when do-renaming? + (unless (null? to-be-renamed) + (let ([txts (list defs-text)]) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source-editor (find-source-editor/defs stx defs-text)]) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (for-each + (λ (txt) (send txt end-edit-sequence)) + txts)))))))) + + ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean + ;; returns #t if the name chosen would be the same as another name in this scope. + (define (name-duplication? to-be-renamed id-sets new-str) + (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) + to-be-renamed)]) + (ormap (λ (id-set) + (ormap (λ (new-id) (get-ids id-set new-id)) + new-ids)) + id-sets))) + + ;; remove-duplicates : (listof syntax[original]) -> (listof syntax[original]) + ;; removes duplicates, based on the source locations of the identifiers + (define (remove-duplicates ids) + (cond + [(null? ids) null] + [else (let loop ([fst (car ids)] + [rst (cdr ids)]) + (cond + [(null? rst) (list fst)] + [else (if (and (eq? (syntax-source fst) + (syntax-source (car rst))) + (= (syntax-position fst) + (syntax-position (car rst)))) + (loop fst (cdr rst)) + (cons fst (loop (car rst) (cdr rst))))]))])) + + + ; + ; + ; + ; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;; ; ; ; ;; + ; ; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ;; ; + ; ; ; ; ; ;;;; ;; ; ; ;; + ; ; + ; ; + ; ; + + + (add-check-syntax-key-bindings (drscheme:rep:get-drs-bindings-keymap)) + (fw:color-prefs:add-to-preferences-panel (string-constant check-syntax) + syncheck-add-to-preferences-panel) + (drscheme:language:register-capability 'drscheme:check-syntax-button (flat-contract boolean?) #t) + (drscheme:get/extend:extend-definitions-text make-syncheck-text%) + (drscheme:get/extend:extend-unit-frame unit-frame-mixin #f) + (drscheme:get/extend:extend-tab tab-mixin))) diff --git a/collects/drscheme/syncheck/utils.ss b/collects/drscheme/syncheck/utils.ss new file mode 100644 index 0000000000..04f956ec59 --- /dev/null +++ b/collects/drscheme/syncheck/utils.ss @@ -0,0 +1,8 @@ +#lang scheme/base + +(provide (all-defined-out)) + +;; use this to communicate the frame being +;; syntax checked w/out having to add new +;; parameters to all of the functions +(define currently-processing-drscheme-frame (make-parameter #f)) \ No newline at end of file