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