diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 2a9ce9c8b9..d68451211b 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -1,3 +1,4 @@ +#lang scheme/base #| Check Syntax separates two classes of identifiers, @@ -15,2463 +16,2485 @@ If the namespace does not, they are colored the unbound color. |# -(module syncheck mzscheme - (require (lib "string-constant.ss" "string-constants") - (lib "unit.ss") - (lib "contract.ss") - (lib "tool.ss" "drscheme") - (lib "class.ss") - (lib "list.ss") - (lib "toplevel.ss" "syntax") - (lib "boundmap.ss" "syntax") - (lib "bitmap-label.ss" "mrlib") - (prefix drscheme:arrow: (lib "arrow.ss" "drscheme")) - (prefix fw: (lib "framework.ss" "framework")) - (lib "mred.ss" "mred")) - (provide tool@) - (define o (current-output-port)) +(require string-constants/string-constant + (lib "unit.ss") + (lib "contract.ss") + (lib "tool.ss" "drscheme") + (lib "class.ss") + (lib "list.ss") + (lib "toplevel.ss" "syntax") + (lib "boundmap.ss" "syntax") + (lib "bitmap-label.ss" "mrlib") + (prefix-in drscheme:arrow: (lib "arrow.ss" "drscheme")) + (prefix-in fw: (lib "framework.ss" "framework")) + (lib "mred.ss" "mred")) +(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 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 - (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 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)) + 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 - (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? - - update-button-visibility/settings) + hide-error-report + get-error-report-text + get-error-report-visible? - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) + 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-drscheme-frame (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)) - - - - - ;;; ;;; ;;; ;;;;; - ; ; ; ; ; - ; ; ; ; ; - ; ; ; ; - ; ;; ; ; ; - ; ; ; ; ; - ; ; ;; ;; ; - ;;; ;;; ;;;;; - + ;; use this to communicate the frame being + ;; syntax checked w/out having to add new + ;; parameters to all of the functions + (define currently-processing-drscheme-frame (make-parameter #f)) + + (define (phase1) + (drscheme:unit:add-to-program-editor-mixin clearing-text-mixin)) + (define (phase2) (void)) + + (define (printf . args) (apply fprintf o args)) + + + + + ;;; ;;; ;;; ;;;;; + ; ; ; ; ; + ; ; ; ; ; + ; ; ; ; + ; ;; ; ; ; + ; ; ; ; ; + ; ; ;; ;; ; + ;;; ;;; ;;;;; + + + ;; 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?)) + (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) + + ;; 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 + position-location + get-canvas last-position dc-location-to-editor-location + find-position begin-edit-sequence end-edit-sequence) - ;; 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)) - (define-struct (var-arrow arrow) - (start-text start-pos-left start-pos-right - end-text end-pos-left end-pos-right - actual?)) - (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos)) - - ;; id : symbol -- the nominal-source-id from identifier-binding - ;; filename : path - (define-struct def-link (id filename) (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 - position-location - get-canvas last-position dc-location-to-editor-location - find-position begin-edit-sequence end-edit-sequence) + + + ;; 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-table 'equal)) + + ;; 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-table-get bindings-table key (λ () '()))] + [new (list end-text end-left end-right)]) + (cond + [(member new priors) + #f] + [else + (hash-table-put! 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 (first l1)] + [start-left (second l1)] + [end-text (first l2)] + [end-left (second l2)]) + (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)))) - ;; 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-table 'equal)) - - ;; 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-table-get bindings-table key (λ () '()))] - [new (list end-text end-left end-right)]) - (cond - [(member new priors) - #f] - [else - (hash-table-put! 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 (first l1)] - [start-left (second l1)] - [end-text (first l2)] - [end-left (second l2)]) - (let-values ([(sx sy) (find-dc-location start-text start-left)] - [(ex ey) (find-dc-location end-text end-left)]) + (hash-table-for-each + bindings-table + (λ (k v) + (hash-table-put! bindings-table k (sort v compare-bindings))))) + + (define tacked-hash-table (make-hash-table)) + (define cursor-location #f) + (define cursor-text #f) + (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))))) + + ;; 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) + (let-values ([(start-x start-y) (find-poss + (tail-arrow-from-text arrow) + (tail-arrow-from-pos arrow) + (+ (tail-arrow-from-pos arrow) 1))] + [(end-x end-y) (find-poss + (tail-arrow-to-text arrow) + (tail-arrow-to-pos arrow) + (+ (tail-arrow-to-pos arrow) 1))]) + (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))) + + ;; syncheck:init-arrows : -> void + (define/public (syncheck:init-arrows) + (set! tacked-hash-table (make-hash-table)) + (set! arrow-vectors (make-hash-table)) + (set! bindings-table (make-hash-table 'equal)) + (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-table-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) + (when any-tacked? + (invalidate-bitmap-cache)) + (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))) + + ;; 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?) + (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?)]) + (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 from-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-table-get + arrow-vectors + text + (λ () + (let ([new-vec + (make-vector + (add1 (send text last-position)) + null)]) + (hash-table-put! + arrow-vectors + text + new-vec) + new-vec)))]) + (let loop ([p start]) + (when (<= p end) + (let ([r (vector-ref arrow-vector p)]) (cond - [(= sy ey) (< sx ex)] - [else (< sy ey)])))) + [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-table-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-table-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) + (super 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-table-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-table-get 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)))) + + ;; 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-hash-table)) + + (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text + tail-arrow-other-pos tail-arrow-other-text) - ;; 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-table-for-each - bindings-table - (λ (k v) - (hash-table-put! bindings-table k (sort v compare-bindings))))) - - (define tacked-hash-table (make-hash-table)) - (define cursor-location #f) - (define cursor-text #f) - (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))))) - - ;; 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) - (let-values ([(start-x start-y) (find-poss - (tail-arrow-from-text arrow) - (tail-arrow-from-pos arrow) - (+ (tail-arrow-from-pos arrow) 1))] - [(end-x end-y) (find-poss - (tail-arrow-to-text arrow) - (tail-arrow-to-pos arrow) - (+ (tail-arrow-to-pos arrow) 1))]) - (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))) - - ;; syncheck:init-arrows : -> void - (define/public (syncheck:init-arrows) - (set! tacked-hash-table (make-hash-table)) - (set! arrow-vectors (make-hash-table)) - (set! bindings-table (make-hash-table 'equal)) - (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-table-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) - (when any-tacked? - (invalidate-bitmap-cache)) - (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))) - - ;; 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?) - (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?)]) - (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 from-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-table-get - arrow-vectors - text - (λ () - (let ([new-vec - (make-vector - (add1 (send text last-position)) - null)]) - (hash-table-put! - arrow-vectors - text - new-vec) - new-vec)))]) - (let loop ([p start]) - (when (<= p end) - (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-table-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-table-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) - (super 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-table-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-table-get arrow-vectors cursor-text (λ () #f))]) + ;; traversal-ht ensures that we don't loop in the arrow traversal. + (let ([traversal-ht (make-hash-table)]) + (let loop ([tail-arrow tail-arrow]) + (unless (hash-table-get traversal-ht tail-arrow (λ () #f)) + (hash-table-put! traversal-ht tail-arrow #t) + (unless (hash-table-get call-f-ht tail-arrow (λ () #f)) + (hash-table-put! 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-table-get arrow-vectors next-text (λ () #f))]) (when arrow-vector - (let ([eles (vector-ref arrow-vector cursor-location)]) + (let ([eles (vector-ref arrow-vector next-pos)]) (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)))) + (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 : (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-hash-table)) - - (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-hash-table)]) - (let loop ([tail-arrow tail-arrow]) - (unless (hash-table-get traversal-ht tail-arrow (λ () #f)) - (hash-table-put! traversal-ht tail-arrow #t) - (unless (hash-table-get call-f-ht tail-arrow (λ () #f)) - (hash-table-put! 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-table-get 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)) - - ;; get-pos/text : event -> (values (union #f text%) (union number #f)) - ;; returns two #fs to indicate the event doesn't correspond to - ;; a position in an editor, or returns the innermost text - ;; and position in that text where the event is. - (define/private (get-pos/text event) - (let ([event-x (send event get-x)] - [event-y (send event get-y)] - [on-it? (box #f)]) - (let loop ([editor this]) - (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)]) - (cond - [(is-a? editor text%) - (let ([pos (send editor find-position x y #f on-it?)]) - (cond - [(not (unbox on-it?)) (values #f #f)] - [else - (let ([snip (send editor find-snip pos 'after-or-none)]) - (if (and snip - (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values pos editor)))]))] - [(is-a? editor pasteboard%) - (let ([snip (send editor find-snip x y)]) - (if (and snip - (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values #f #f)))] - [else (values #f #f)]))))) - - (define/override (on-event event) - (if arrow-vectors + (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)) + + ;; get-pos/text : event -> (values (union #f text%) (union number #f)) + ;; returns two #fs to indicate the event doesn't correspond to + ;; a position in an editor, or returns the innermost text + ;; and position in that text where the event is. + (define/private (get-pos/text event) + (let ([event-x (send event get-x)] + [event-y (send event get-y)] + [on-it? (box #f)]) + (let loop ([editor this]) + (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)]) (cond - [(send event leaving?) - (when (and cursor-location cursor-text) - (set! cursor-location #f) - (set! cursor-text #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)]) + [(is-a? editor text%) + (let ([pos (send editor find-position x y #f on-it?)]) (cond - [(and pos text) - (unless (and (equal? pos cursor-location) - (eq? cursor-text text)) - (set! cursor-location pos) - (set! cursor-text text) - - (let* ([arrow-vector (hash-table-get arrow-vectors cursor-text (λ () #f))] - [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) - (when 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)))))) - - (when eles + [(not (unbox on-it?)) (values #f #f)] + [else + (let ([snip (send editor find-snip pos 'after-or-none)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values pos editor)))]))] + [(is-a? editor pasteboard%) + (let ([snip (send editor find-snip x y)]) + (if (and snip + (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values #f #f)))] + [else (values #f #f)]))))) + + (define/override (on-event event) + (if arrow-vectors + (cond + [(send event leaving?) + (when (and cursor-location cursor-text) + (set! cursor-location #f) + (set! cursor-text #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 text) + (unless (and (equal? pos cursor-location) + (eq? cursor-text text)) + (set! cursor-location pos) + (set! cursor-text text) + + (let* ([arrow-vector (hash-table-get arrow-vectors cursor-text (λ () #f))] + [eles (and arrow-vector (vector-ref arrow-vector cursor-location))]) + (when eles + (let ([has-txt? #f]) (for-each (λ (ele) (cond - [(arrow? ele) - (update-arrow-poss ele)])) + [(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) - (invalidate-bitmap-cache))))] - [else - (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) - (invalidate-bitmap-cache))])) - (super on-event event)] - [(send event button-down? 'right) - (let-values ([(pos text) (get-pos/text event)]) - (if (and pos text) - (let ([arrow-vector (hash-table-get arrow-vectors text (λ () #f))]) - (when arrow-vector - (let ([vec-ents (vector-ref arrow-vector pos)]) - (cond - [(null? vec-ents) - (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 cons? 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)))) - (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))) - - ;; tack/untack-callback : (listof arrow) -> void - ;; callback for the tack/untack menu item - (define/private (tack/untack-callback arrows) - (let ([arrow-tacked? - (λ (arrow) - (hash-table-get - 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-table-put! tacked-hash-table arrow (not untack-arrows?))] - [(tail-arrow? arrow) - (for-each-tail-arrows - (λ (arrow) - (hash-table-put! tacked-hash-table arrow (not untack-arrows?))) - arrow)])) - arrows)) - (invalidate-bitmap-cache)) - - ;; 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-table-get 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-table-get 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 (first arrow)) - (<= (second arrow) pos (third arrow))) - (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 (first to-arrow)] - [end-pos-left (second to-arrow)] - [end-pos-right (third to-arrow)]) - (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-table-get 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 - (bitmap-label-maker - (string-constant check-syntax) - (build-path (collection-path "icons") "syncheck.png"))) - - (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/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 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)] - [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] + (unless has-txt? + (let ([f (get-top-level-window)]) + (when f + (send f update-status-line 'drscheme:check-syntax:mouse-over #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) + (when eles + (for-each (λ (ele) + (cond + [(arrow? ele) + (update-arrow-poss ele)])) + eles) + (invalidate-bitmap-cache))))] + [else + (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) + (invalidate-bitmap-cache))])) + (super on-event event)] + [(send event button-down? 'right) + (let-values ([(pos text) (get-pos/text event)]) + (if (and pos text) + (let ([arrow-vector (hash-table-get arrow-vectors text (λ () #f))]) + (when arrow-vector + (let ([vec-ents (vector-ref arrow-vector pos)]) + (cond + [(null? vec-ents) + (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 cons? 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)))) + (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))) + + ;; tack/untack-callback : (listof arrow) -> void + ;; callback for the tack/untack menu item + (define/private (tack/untack-callback arrows) + (let ([arrow-tacked? + (λ (arrow) + (hash-table-get + 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-table-put! tacked-hash-table arrow (not untack-arrows?))] + [(tail-arrow? arrow) + (for-each-tail-arrows + (λ (arrow) + (hash-table-put! tacked-hash-table arrow (not untack-arrows?))) + arrow)])) + arrows)) + (invalidate-bitmap-cache)) + + ;; 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-table-get 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-table-get 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 (first arrow)) + (<= (second arrow) pos (third arrow))) + (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 (first to-arrow)] + [end-pos-left (second to-arrow)] + [end-pos-right (third to-arrow)]) + (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-table-get 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 + (bitmap-label-maker + (string-constant check-syntax) + (build-path (collection-path "icons") "syncheck.png"))) + + (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/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 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)] + [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 - (λ () ;; =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= - (show-error-report/tab)))) - - (drscheme:debug:show-error-and-highlight - msg exn - (λ (src-to-display cms) ;; =user= - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () ;; =drs= - (send (send the-tab get-ints) highlight-errors src-to-display cms)))))) - - (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 - (get-post-hash-bang-start definitions-text) - (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) + (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= - (with-lock/edit-sequence - definitions-text - (λ () - (parameterize ([currently-processing-drscheme-frame this]) - (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) - (update-status-line 'drscheme:check-syntax status-coloring-program) - (parameterize ([currently-processing-drscheme-frame this]) - (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)]))))))))))])) - - (define/private (get-post-hash-bang-start definitions-text) - (cond - [(< (send definitions-text last-position) 2) - 0] - [(equal? '(#\# #\!) - (list (send definitions-text get-character 0) - (send definitions-text get-character 1))) - (let ([last-para (send definitions-text last-paragraph)]) - (if (zero? last-para) - (send definitions-text last-position) - (send definitions-text paragraph-start-position 1)))] - [else 0])) - - ;; 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 button% - (label (syncheck-bitmap this)) - (parent check-syntax-button-parent-panel) - (callback (λ (button evt) (syncheck:button-callback))))) - (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)))) + (λ () ;; =drs= + (show-error-report/tab)))) + + (drscheme:debug:show-error-and-highlight + msg exn + (λ (src-to-display cms) ;; =user= + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () ;; =drs= + (send (send the-tab get-ints) highlight-errors src-to-display cms)))))) + + (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 + (get-post-hash-bang-start definitions-text) + (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-drscheme-frame this]) + (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) + (update-status-line 'drscheme:check-syntax status-coloring-program) + (parameterize ([currently-processing-drscheme-frame this]) + (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)]))))))))))])) + + (define/private (get-post-hash-bang-start definitions-text) + (cond + [(< (send definitions-text last-position) 2) + 0] + [(equal? '(#\# #\!) + (list (send definitions-text get-character 0) + (send definitions-text get-character 1))) + (let ([last-para (send definitions-text last-paragraph)]) + (if (zero? last-para) + (send definitions-text last-position) + (send definitions-text paragraph-start-position 1)))] + [else 0])) + + ;; 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 button% + (label (syncheck-bitmap this)) + (parent check-syntax-button-parent-panel) + (callback (λ (button evt) (syncheck:button-callback))))) + (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)))))))) - (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) + (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 - "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) + "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))))) - (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-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 + (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-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 - 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-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 (lambda case-lambda if begin begin0 let-values letrec-values set! - quote quote-syntax with-continuation-mark - #%app #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntax module - #%require #%provide) - (if high-level? module-transformer-identifier=? module-identifier=?) - [(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)))] - [(if test then) - (begin - (annotate-raw-keyword sexp varrefs) - (annotate-tail-position sexp (syntax then) tail-ht) - (loop (syntax test)) - (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). - (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) + 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-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) - (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)))] - [(#%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-table-put! requires - (syntax-object->datum (syntax lang)) - (cons (syntax lang) - (hash-table-get requires - (syntax-object->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) - (add-id varrefs provided-var)) - provided-vars)) - provided-varss))] - - [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-object->datum sexp)) - (and (syntax? sexp) - (syntax-source sexp))) - (void))]))) - (add-tail-ht-links tail-ht))) - - ;; 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-object->datum raw-spec)]) - (hash-table-put! require-ht - key - (cons syntax - (hash-table-get require-ht - key - (λ () '())))))))) - - ;; annotate-unused-require : syntax -> void - (define (annotate-unused-require req/tag) - (unless (req/tag-used? req/tag) - (color (req/tag-req-stx req/tag) error-style-name))) - - - ;; 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-table 'equal)] - [unused-requires (make-hash-table 'equal)] - [unused-require-for-syntaxes (make-hash-table 'equal)] - [unused-require-for-templates (make-hash-table 'equal)] - [unused-require-for-labels (make-hash-table 'equal)] - ;; 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-table-for-each requires - (λ (k v) (hash-table-put! unused-requires k #t))) - (hash-table-for-each require-for-syntaxes - (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t))) - (hash-table-for-each require-for-templates - (lambda (k v) (hash-table-put! unused-require-for-templates k #t))) - (hash-table-for-each require-for-labels - (lambda (k v) (hash-table-put! unused-require-for-labels k #t))) - - (for-each (λ (vars) - (for-each (λ (var) - (when (syntax-original? var) - (color-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) - (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) - (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-table-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-table-put! rename-ht - key - (cons stx (hash-table-get rename-ht key (λ () '())))))) - - ;; 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))))) - - ;; 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-object->datum var) - id - (syntax-object->datum req-stx)) - (when id - (add-jump-to-definition - var - id - (get-require-filename req-path user-namespace user-directory))) - (add-mouse-over var (format (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)])) - - - ;; 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-table-get ht key (λ () null))]) - (hash-table-put! ht key (cons var prev))))) - - ;; connect-syntaxes : syntax[original] syntax[original] boolean -> void - ;; adds an arrow from `from' to `to', unless they have the same source loc. - (define (connect-syntaxes from to actual?) - (let ([drs-frame (currently-processing-drscheme-frame)]) - (when drs-frame - (let ([defs-text (send drs-frame get-definitions-text)]) - (when (and (send defs-text port-name-matches? (syntax-source from)) - (send defs-text port-name-matches? (syntax-source to))) - (let ([from-source defs-text] ;; these two aren't right in the case of embedded editors - [to-source defs-text] ;; these two aren't right in the case of embedded editors - [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?)))))))))) - - ;; 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 (syntax-source stx)]) - (when (is-a? source text%) - (let ([syncheck-text (find-syncheck-text source)]) - (when (and syncheck-text - (syntax-position stx) - (syntax-span stx)) - (let* ([pos-left (- (syntax-position stx) 1)] - [pos-right (+ pos-left (syntax-span stx))]) - (send syncheck-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 a mouse over - ;; this area shows up in the status line. - (define (add-jump-to-definition stx id filename) - (let ([source (syntax-source stx)]) - (when (is-a? source text%) - (let ([syncheck-text (find-syncheck-text source)]) - (when (and syncheck-text - (syntax-position stx) - (syntax-span stx)) - (let* ([pos-left (- (syntax-position stx) 1)] - [pos-right (+ pos-left (syntax-span stx))]) - (send syncheck-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-table-put! - tail-ht - orig-stx - (cons - tail-stx - (hash-table-get - 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 (syntax-source require-spec)]) - (when (and (is-a? source text%) - (syntax-position require-spec) - (syntax-span require-spec)) - (let ([syncheck-text (find-syncheck-text source)]) - (when syncheck-text - (let* ([start (- (syntax-position require-spec) 1)] - [end (+ start (syntax-span require-spec))] - [file (get-require-filename (syntax-object->datum require-spec) - user-namespace - user-directory)]) - (when file - (send syncheck-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* ([sym - (and (not (symbol? datum)) - (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 (symbol? sym) - (module-name-sym->filename sym)))) - - ;; 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 (format (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) 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)]) + (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). + (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-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) + (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))) + + ;; 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 - [(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))])))) + [(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-table-put! require-ht + key + (cons syntax + (hash-table-get require-ht + key + (λ () '())))))))) + + ;; annotate-unused-require : syntax -> void + (define (annotate-unused-require req/tag) + (unless (req/tag-used? req/tag) + (color (req/tag-req-stx req/tag) error-style-name))) + + + ;; 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) - ;; 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-hash-table)]) - ;; ht : stx -o> true - ;; indicates if we've seen this syntax object before - - (let loop ([stx stx] - [datum (syntax-object->datum stx)]) - (unless (hash-table-get ht datum (λ () #f)) - (hash-table-put! 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 (syntax-source 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 (syntax-source 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))) - - ;; 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 (syntax-source to-stx)] - [from-src (syntax-source from-stx)] - [to-outermost-src (and (is-a? to-src editor<%>) - (find-outermost-editor to-src))] - [from-outermost-src (and (is-a? from-src editor<%>) - (find-outermost-editor from-src))]) - (when (and (is-a? to-outermost-src syncheck-text<%>) - (eq? from-outermost-src to-outermost-src)) - (let ([from-pos (syntax-position from-stx)] - [to-pos (syntax-position to-stx)]) - (when (and from-pos to-pos) - (send to-outermost-src syncheck:add-tail-arrow - from-src (- from-pos 1) - to-src (- to-pos 1))))))) - - ;; 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)))) - - ;; 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-object->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 (format (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) - (format (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) - (format (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)))))))) - - ;; 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-object 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) + (let ([rename-ht + ;; hash-table[(list source number number) -> (listof syntax)] + (make-hash-table 'equal)] + [unused-requires (make-hash-table 'equal)] + [unused-require-for-syntaxes (make-hash-table 'equal)] + [unused-require-for-templates (make-hash-table 'equal)] + [unused-require-for-labels (make-hash-table 'equal)] + ;; 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-table-for-each requires + (λ (k v) (hash-table-put! unused-requires k #t))) + (hash-table-for-each require-for-syntaxes + (λ (k v) (hash-table-put! unused-require-for-syntaxes k #t))) + (hash-table-for-each require-for-templates + (lambda (k v) (hash-table-put! unused-require-for-templates k #t))) + (hash-table-for-each require-for-labels + (lambda (k v) (hash-table-put! unused-require-for-labels k #t))) + + (for-each (λ (vars) + (for-each (λ (var) + (when (syntax-original? var) + (color-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) + (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) + (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-table-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-table-put! rename-ht + key + (cons stx (hash-table-get rename-ht key (λ () '())))))) + + ;; 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))))) + + ;; 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 (format (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)])) + + + ;; 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 - [(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)))) - - - ; - ; - ; - ; ; ; ; ; - ; ; ; ; - ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;; ; ; ; ;; - ; ; ; ; ; ; ;; ; ; ; ; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;;;;;; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ;; ;; ; - ; ; ; ; ; ;;;; ;; ; ; ;; - ; ; - ; ; - ; ; - - - (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)))) + [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-table-get ht key (λ () null))]) + (hash-table-put! ht key (cons var prev))))) + + ;; connect-syntaxes : syntax[original] syntax[original] boolean -> void + ;; adds an arrow from `from' to `to', unless they have the same source loc. + (define (connect-syntaxes from to actual?) + (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?)))))))) + + ;; 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-table-put! + tail-ht + orig-stx + (cons + tail-stx + (hash-table-get + 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 (format (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) 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-hash-table)]) + ;; ht : stx -o> true + ;; indicates if we've seen this syntax object before + + (let loop ([stx stx] + [datum (syntax->datum stx)]) + (unless (hash-table-get ht datum (λ () #f)) + (hash-table-put! 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 (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))) + + ;; 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))))))) + + ;; 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 : definitions-text source -> editor or false + (define (find-source-editor stx) + (let ([defs-text (get-defs-text)]) + (and defs-text + (send defs-text port-name-matches? (syntax-source stx)) + defs-text))) + + ;; 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)))) + + + ; + ; + ; + ; ; + ; ; + ; + ; ; ;; ;;; ;;;; ;;;; ;;;;; ; ;;;; ;;;; + ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; + ; ; ;;; ; ; ;; ; ; ; ; ; ; ; ;;;; + ; ; + ; ; ; + ; ;;; + + + ;; 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 (format (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) + (format (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) + (format (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)))))))) + + ;; 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)))) + + + ; + ; + ; + ; ; ; ; ; + ; ; ; ; + ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;; ; ; ; ;; + ; ; ; ; ; ; ;; ; ; ; ; ;; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;;;;;; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ;; ; + ; ; ; ; ; ;;;; ;; ; ; ;; + ; ; + ; ; + ; ; + + + (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))) \ No newline at end of file