From 2518d54da186c727c23fda674a4ebe6b6080b7ff Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 15 Feb 2009 21:48:41 +0000 Subject: [PATCH] syncheck.ss now uses typed code svn: r13616 --- collects/drscheme/syncheck.ss | 159 +- 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 | 288 +- collects/drscheme/syncheck/make-traversal.ss | 86 - collects/drscheme/syncheck/syncheck.ss | 2755 ------------------ 7 files changed, 16 insertions(+), 4034 deletions(-) delete mode 100644 collects/drscheme/syncheck/annotate.ss delete mode 100644 collects/drscheme/syncheck/color.ss delete mode 100644 collects/drscheme/syncheck/extra-stxcase.ss delete mode 100644 collects/drscheme/syncheck/make-traversal.ss delete mode 100644 collects/drscheme/syncheck/syncheck.ss diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 0e8256683e..9e5f4f7707 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -36,6 +36,8 @@ If the namespace does not, they are colored the unbound color. net/url net/uri-codec browser/external + "syncheck/id-sets.ss" + "syncheck/extra-typed.ss" (for-syntax scheme/base)) (provide tool@) @@ -1475,10 +1477,7 @@ If the namespace does not, they are colored the unbound color. 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] @@ -2160,25 +2159,6 @@ If the namespace does not, they are colored the unbound color. [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 @@ -2225,37 +2205,6 @@ If the namespace does not, they are colored the unbound color. (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) @@ -2295,42 +2244,6 @@ If the namespace does not, they are colored the unbound color. (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)]) @@ -2701,72 +2614,6 @@ If the namespace does not, they are colored the unbound color. (λ (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))))]))])) - - - ; - ; - ; - ; ; ; - ; ; - ; ; ; - ; ; ;; ; ;;; ;;; ;;;; ;;; - ; ; ; ;; ; ; ; ; ; - ; ; ; ; ;; ; ; ; ;; - ; ; ; ; ;; ;;;;;; ; ;; - ; ; ; ; ; ; ; ; - ; ; ; ;; ; ; ; ; - ; ; ;; ; ;;; ;;;; ;; ;;; - ; - ; - ; - - ;; make-id-set : -> id-set - (define (make-id-set) (make-module-identifier-mapping)) - - ;; 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 y) y))) - - ;; get-ids : id-set identifier -> (union (listof identifier) #f) - (define (get-ids mapping var) - (module-identifier-mapping-get 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 y) (f y)))) - - ; ; ; diff --git a/collects/drscheme/syncheck/annotate.ss b/collects/drscheme/syncheck/annotate.ss deleted file mode 100644 index 087aba6e3b..0000000000 --- a/collects/drscheme/syncheck/annotate.ss +++ /dev/null @@ -1,634 +0,0 @@ -#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 deleted file mode 100644 index a1c6ef45a9..0000000000 --- a/collects/drscheme/syncheck/color.ss +++ /dev/null @@ -1,84 +0,0 @@ -#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 deleted file mode 100644 index d5ac6927cc..0000000000 --- a/collects/drscheme/syncheck/extra-stxcase.ss +++ /dev/null @@ -1,44 +0,0 @@ -#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 index 6c1555dc9f..6d2a4d3f93 100644 --- a/collects/drscheme/syncheck/extra-typed.ss +++ b/collects/drscheme/syncheck/extra-typed.ss @@ -79,7 +79,6 @@ (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) @@ -100,7 +99,19 @@ orig-stx (λ () null))))) -;; add-disappeared-uses : 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)]))))) + (: add-disappeared-uses (Syntax Id-Set -> Void)) (define (add-disappeared-uses stx id-set) (let ([prop (syntax-property stx 'disappeared-use)]) @@ -129,13 +140,11 @@ 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)]) @@ -151,21 +160,6 @@ [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)]) @@ -193,259 +187,3 @@ [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))) -|# diff --git a/collects/drscheme/syncheck/make-traversal.ss b/collects/drscheme/syncheck/make-traversal.ss deleted file mode 100644 index efe7dd3dff..0000000000 --- a/collects/drscheme/syncheck/make-traversal.ss +++ /dev/null @@ -1,86 +0,0 @@ -#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 deleted file mode 100644 index 0e5055440d..0000000000 --- a/collects/drscheme/syncheck/syncheck.ss +++ /dev/null @@ -1,2755 +0,0 @@ -#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)))