suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add menus and keybindings for jumping around to the errors in the defs

Browse Source 
window

also a little line-length shrinking
This commit is contained in:
Robby Findler 2011-09-19 22:47:47 -05:00
parent df43d90513
commit 252db20c85
5 changed files with 318 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/drracket/private/local-member-names.rkt
View File

@ -12,4 +12,8 @@
;; from module-language-tools.rkt ;; from module-language-tools.rkt
(define-local-member-name when-initialized #;move-to-new-language get-in-module-language?) (define-local-member-name when-initialized #;move-to-new-language get-in-module-language?)
;; for keybindings (otherwise private)
(define-local-member-name
jump-to-previous-error-loc
jump-to-next-error-loc)

38
collects/drracket/private/module-language.rkt
View File

@ -1271,12 +1271,12 @@
(send (get-tab) show-bkg-running 'nothing #f) (send (get-tab) show-bkg-running 'nothing #f)
(set! error-message-str (vector-ref res 1)) (set! error-message-str (vector-ref res 1))
(set! error-message-srclocs (vector-ref res 2)) (set! error-message-srclocs (vector-ref res 2))
(set! error-ranges (set-online-error-ranges
(for/list ([range (in-list (vector-ref res 2))]) (for/list ([range (in-list (vector-ref res 2))])
(define pos (vector-ref range 0)) (define pos (vector-ref range 0))
(define span (vector-ref range 1)) (define span (vector-ref range 1))
(error-range (- pos 1) (+ pos span -1) #f))) (error-range (- pos 1) (+ pos span -1) #f)))
;; should really only invalidate the appropriate region here (and in clear-error-ranges) ;; should really only invalidate the appropriate region here (and in clear-online-error-ranges)
(invalidate-bitmap-cache 0 0 'display-end 'display-end) (invalidate-bitmap-cache 0 0 'display-end 'display-end)
(update-frame-expand-error)] (update-frame-expand-error)]
[(access-violation) [(access-violation)
@ -1313,13 +1313,23 @@
(error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)])) (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)]))
(define error-ranges '()) (define online-error-ranges '())
(define/private (set-online-error-ranges rngs)
(set! online-error-ranges rngs)
(send (send (get-tab) get-ints) set-error-ranges
(map (λ (x) (srcloc this
#f
#f
(+ (error-range-start x) 1)
(- (error-range-end x)
(error-range-start x))))
rngs)))
(define/private (clear-old-error) (define/private (clear-old-error)
(for ([an-error-range (in-list error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
(when (error-range-clear-highlight an-error-range) (when (error-range-clear-highlight an-error-range)
((error-range-clear-highlight an-error-range)) ((error-range-clear-highlight an-error-range))
(set-error-range-clear-highlight! an-error-range #f))) (set-error-range-clear-highlight! an-error-range #f)))
(set! error-ranges '()) (set-online-error-ranges '())
(invalidate-bitmap-cache 0 0 'display-end 'display-end)) (invalidate-bitmap-cache 0 0 'display-end 'display-end))
(define byt (box 0.0)) (define byt (box 0.0))
@ -1349,7 +1359,7 @@
.5 .5
.25)) .25))
(for ([an-error-range (in-list error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
(define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range)) (define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range))
(send path move-to (+ dx x2) (+ dy y2)) (send path move-to (+ dx x2) (+ dy y2))
@ -1373,7 +1383,7 @@
(cond (cond
[(or (send evt moving?) [(or (send evt moving?)
(send evt entering?)) (send evt entering?))
(for ([an-error-range (in-list error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
(define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range)) (define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range))
(cond (cond
[(and (<= x1 mx x2) [(and (<= x1 mx x2)
@ -1390,14 +1400,14 @@
(set-error-range-clear-highlight! an-error-range #f))])) (set-error-range-clear-highlight! an-error-range #f))]))
(super on-event evt)] (super on-event evt)]
[(send evt leaving?) [(send evt leaving?)
(for ([an-error-range (in-list error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
(when (error-range-clear-highlight an-error-range) (when (error-range-clear-highlight an-error-range)
((error-range-clear-highlight an-error-range)) ((error-range-clear-highlight an-error-range))
(set-error-range-clear-highlight! an-error-range #f))) (set-error-range-clear-highlight! an-error-range #f)))
(super on-event evt)] (super on-event evt)]
[(send evt button-down? 'left) [(send evt button-down? 'left)
(define used-click? #f) (define used-click? #f)
(for ([an-error-range (in-list error-ranges)]) (for ([an-error-range (in-list online-error-ranges)])
(define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range)) (define-values (x1 y1 x2 y2 x3 y3 x4 y4) (get-box an-error-range))
(when (and (<= x1 mx x2) (when (and (<= x1 mx x2)
(<= y2 my y3)) (<= y2 my y3))
@ -1526,7 +1536,7 @@
(compile-lock->parallel-lock-client (compile-lock->parallel-lock-client
module-language-compile-lock module-language-compile-lock
(current-custodian))) (current-custodian)))
;; in-module-language : top-level-window<%> -> module-language-settings or #f ;; in-module-language : top-level-window<%> -> module-language-settings or #f
(define (in-module-language tlw) (define (in-module-language tlw)
(and tlw (and tlw

209
collects/drracket/private/rep.rkt
View File

@ -28,6 +28,7 @@ TODO
framework framework
browser/external browser/external
"drsig.rkt" "drsig.rkt"
"local-member-names.rkt"
;; the dynamic-require below loads this module, ;; the dynamic-require below loads this module,
;; so we make the dependency explicit here, even ;; so we make the dependency explicit here, even
@ -250,7 +251,18 @@ TODO
(add-drs-function "next-tab" (λ (frame) (send frame next-tab))) (add-drs-function "next-tab" (λ (frame) (send frame next-tab)))
(add-drs-function "prev-tab" (λ (frame) (send frame prev-tab))) (add-drs-function "prev-tab" (λ (frame) (send frame prev-tab)))
(add-drs-function "collapse" (λ (frame) (send frame collapse))) (add-drs-function "collapse" (λ (frame) (send frame collapse)))
(add-drs-function "split" (λ (frame) (send frame split)))) (add-drs-function "split" (λ (frame) (send frame split)))
(add-drs-function "jump-to-previous-error-loc"
(λ (frame) (send frame jump-to-previous-error-loc)))
(add-drs-function "jump-to-next-error-loc"
(λ (frame) (send frame jump-to-next-error-loc))))
(send drs-bindings-keymap map-function "m:p" "jump-to-previous-error-loc")
(send drs-bindings-keymap map-function "m:n" "jump-to-next-error-loc")
(send drs-bindings-keymap map-function "esc;p" "jump-to-previous-error-loc")
(send drs-bindings-keymap map-function "esc;n" "jump-to-next-error-loc")
(send drs-bindings-keymap map-function "c:x;`" "jump-to-next-error-loc")
(send drs-bindings-keymap map-function "f5" "execute") (send drs-bindings-keymap map-function "f5" "execute")
(send drs-bindings-keymap map-function "f1" "search-help-desk") (send drs-bindings-keymap map-function "f1" "search-help-desk")
@ -591,6 +603,10 @@ TODO
;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number))))
(define error-ranges #f) (define error-ranges #f)
(define/public (get-error-ranges) error-ranges) (define/public (get-error-ranges) error-ranges)
(define/public (set-error-ranges ranges)
(set! error-ranges (and ranges
(not (null? ranges))
(cleanup-locs ranges))))
(define internal-reset-callback void) (define internal-reset-callback void)
(define internal-reset-error-arrows-callback void) (define internal-reset-error-arrows-callback void)
(define/public (reset-error-ranges) (define/public (reset-error-ranges)
@ -615,105 +631,104 @@ TODO
;; (union #f (listof srcloc)) ;; (union #f (listof srcloc))
;; -> (void) ;; -> (void)
(define/public (highlight-errors raw-locs [raw-error-arrows #f]) (define/public (highlight-errors raw-locs [raw-error-arrows #f])
(let* ([cleanup-locs (set-error-ranges raw-locs)
(λ (locs) (define locs (get-error-ranges)) ;; calling set-error-range cleans up the locs
(let ([ht (make-hasheq)]) (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))
(filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
(number? (srcloc-position loc)) (reset-highlighting)
(number? (srcloc-span loc))))
(map (λ (srcloc) (for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs)
(cond
[(hash-ref ht (srcloc-source srcloc) #f) (when color?
=> (let ([resets
(λ (e) (map (λ (loc)
(make-srcloc e (let* ([file (srcloc-source loc)]
(srcloc-line srcloc) [start (- (srcloc-position loc) 1)]
(srcloc-column srcloc) [span (srcloc-span loc)]
(srcloc-position srcloc) [finish (+ start span)])
(srcloc-span srcloc)))] (send file highlight-range start finish (drracket:debug:get-error-color) #f 'high)))
[(send definitions-text port-name-matches? (srcloc-source srcloc)) locs)])
(hash-set! ht (srcloc-source srcloc) definitions-text)
(make-srcloc definitions-text
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(port-name-matches? (srcloc-source srcloc))
(hash-set! ht (srcloc-source srcloc) this)
(make-srcloc this
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(and (symbol? (srcloc-source srcloc))
(text:lookup-port-name (srcloc-source srcloc)))
=>
(lambda (editor)
(make-srcloc editor
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc)))]
[else srcloc]))
locs))))]
[locs (cleanup-locs raw-locs)]
[error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))])
(reset-highlighting)
(set! error-ranges locs)
(for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs)
(when color?
(let ([resets
(map (λ (loc)
(let* ([file (srcloc-source loc)]
[start (- (srcloc-position loc) 1)]
[span (srcloc-span loc)]
[finish (+ start span)])
(send file highlight-range start finish (drracket:debug:get-error-color) #f 'high)))
locs)])
(when (and definitions-text error-arrows)
(let ([filtered-arrows
(remove-duplicate-error-arrows
(filter
(λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
error-arrows))])
(send definitions-text set-error-arrows filtered-arrows)))
(set! internal-reset-callback
(λ ()
(set! error-ranges #f)
(when definitions-text
(send definitions-text set-error-arrows #f))
(set! internal-reset-callback void)
(for-each (λ (x) (x)) resets)))))
(let* ([first-loc (and (pair? locs) (car locs))]
[first-file (and first-loc (srcloc-source first-loc))]
[first-start (and first-loc (- (srcloc-position first-loc) 1))]
[first-span (and first-loc (srcloc-span first-loc))])
(when (and first-loc first-start first-span) (when (and definitions-text error-arrows)
(let ([first-finish (+ first-start first-span)]) (let ([filtered-arrows
(when (eq? first-file definitions-text) ;; only move set the cursor in the defs window (remove-duplicate-error-arrows
(send first-file set-position first-start first-start)) (filter
(send first-file scroll-to-position first-start #f first-finish))) (λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
error-arrows))])
(send definitions-text set-error-arrows filtered-arrows)))
(for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs) (set! internal-reset-callback
(λ ()
(set-error-ranges #f)
(when definitions-text
(send definitions-text set-error-arrows #f))
(set! internal-reset-callback void)
(for-each (λ (x) (x)) resets)))))
(let* ([first-loc (and (pair? locs) (car locs))]
[first-file (and first-loc (srcloc-source first-loc))]
[first-start (and first-loc (- (srcloc-position first-loc) 1))]
[first-span (and first-loc (srcloc-span first-loc))])
(when (and first-loc first-start first-span)
(let ([first-finish (+ first-start first-span)])
(when (eq? first-file definitions-text) ;; only move set the cursor in the defs window
(send first-file set-position first-start first-start))
(send first-file scroll-to-position first-start #f first-finish)))
(for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs)
(when first-loc
(when first-loc (when (eq? first-file definitions-text)
;; when we're highlighting something in the defs window,
(when (eq? first-file definitions-text) ;; make sure it is visible
;; when we're highlighting something in the defs window, (let ([tlw (send first-file get-top-level-window)])
;; make sure it is visible (when (is-a? tlw drracket:unit:frame<%>)
(let ([tlw (send first-file get-top-level-window)]) (send tlw ensure-defs-shown))))
(when (is-a? tlw drracket:unit:frame<%>)
(send tlw ensure-defs-shown)))) (send first-file set-caret-owner (get-focus-snip) 'global))))
(send first-file set-caret-owner (get-focus-snip) 'global))))) (define/private (cleanup-locs locs)
(let ([ht (make-hasheq)])
(filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
(number? (srcloc-position loc))
(number? (srcloc-span loc))))
(map (λ (srcloc)
(cond
[(hash-ref ht (srcloc-source srcloc) #f)
=>
(λ (e)
(make-srcloc e
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc)))]
[(send definitions-text port-name-matches? (srcloc-source srcloc))
(hash-set! ht (srcloc-source srcloc) definitions-text)
(make-srcloc definitions-text
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(port-name-matches? (srcloc-source srcloc))
(hash-set! ht (srcloc-source srcloc) this)
(make-srcloc this
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc))]
[(and (symbol? (srcloc-source srcloc))
(text:lookup-port-name (srcloc-source srcloc)))
=>
(lambda (editor)
(make-srcloc editor
(srcloc-line srcloc)
(srcloc-column srcloc)
(srcloc-position srcloc)
(srcloc-span srcloc)))]
[else srcloc]))
locs))))
(define highlights-can-be-reset (make-parameter #t)) (define highlights-can-be-reset (make-parameter #t))
(define/public (reset-highlighting) (define/public (reset-highlighting)

219
collects/drracket/private/unit.rkt
View File

@ -1433,7 +1433,9 @@ module browser threading seems wrong.
(remq logger-panel l)])))] (remq logger-panel l)])))]
[else [else
(when show? ;; if we want to hide and it isn't built yet, do nothing (when show? ;; if we want to hide and it isn't built yet, do nothing
(define logger-gui-tab-panel-parent (new horizontal-panel% [parent logger-panel] [stretchable-height #f])) (define logger-gui-tab-panel-parent (new horizontal-panel%
[parent logger-panel]
[stretchable-height #f]))
(set! logger-gui-tab-panel (set! logger-gui-tab-panel
(new tab-panel% (new tab-panel%
[choices (list (string-constant logging-all) [choices (list (string-constant logging-all)
@ -1443,7 +1445,8 @@ module browser threading seems wrong.
[style '(no-border)] [style '(no-border)]
[callback [callback
(λ (tp evt) (λ (tp evt)
(preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) (preferences:set 'drracket:logger-gui-tab-panel-level
(send logger-gui-tab-panel get-selection))
(update-logger-window #f))])) (update-logger-window #f))]))
(new button% [label (string-constant hide-log)] (new button% [label (string-constant hide-log)]
[callback (λ (x y) (send current-tab hide-log))] [callback (λ (x y) (send current-tab hide-log))]
@ -1554,7 +1557,10 @@ module browser threading seems wrong.
(new message% (new message%
[parent planet-status-panel] [parent planet-status-panel]
[label drracket:debug:small-planet-bitmap]) [label drracket:debug:small-planet-bitmap])
(set! planet-message (new message% [parent planet-status-panel] [label ""] [stretchable-width #t])) (set! planet-message (new message%
[parent planet-status-panel]
[label ""]
[stretchable-width #t]))
(set! planet-logger-button (set! planet-logger-button
(new button% (new button%
[font small-control-font] [font small-control-font]
@ -1688,10 +1694,11 @@ module browser threading seems wrong.
(λ (exn) (λ (exn)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(gui-utils:format-literal-label (string-constant error-erasing-log-directory) (gui-utils:format-literal-label
(if (exn? exn) (string-constant error-erasing-log-directory)
(format "~a" (exn-message exn)) (if (exn? exn)
(format "~s" exn))) (format "~a" (exn-message exn))
(format "~s" exn)))
this this
#:dialog-mixin frame:focus-table-mixin) #:dialog-mixin frame:focus-table-mixin)
#f)]) #f)])
@ -1762,7 +1769,8 @@ module browser threading seems wrong.
(preferences:set 'drracket:toolbar-state new-state) (preferences:set 'drracket:toolbar-state new-state)
(update-toolbar-visibility)) (update-toolbar-visibility))
(define/override (on-toolbar-button-click) (change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state)))) (define/override (on-toolbar-button-click)
(change-toolbar-state (cons (not (car toolbar-state)) (cdr toolbar-state))))
(define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left))) (define/private (set-toolbar-left) (change-toolbar-state (cons #f 'left)))
(define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right))) (define/private (set-toolbar-right) (change-toolbar-state (cons #f 'right)))
(define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top))) (define/private (set-toolbar-top) (change-toolbar-state (cons #f 'top)))
@ -1872,7 +1880,8 @@ module browser threading seems wrong.
(for-each loop (send obj get-children))] (for-each loop (send obj get-children))]
[(is-a? obj switchable-button%) [(is-a? obj switchable-button%)
(unless (memq obj toolbar-buttons) (unless (memq obj toolbar-buttons)
(error 'register-toolbar-button "found a switchable-button% that is not registered, label ~s" (error 'register-toolbar-button
"found a switchable-button% that is not registered, label ~s"
(send obj get-label)))] (send obj get-label)))]
[else (void)]))) [else (void)])))
@ -1961,12 +1970,14 @@ module browser threading seems wrong.
(define/public (language-changed) (define/public (language-changed)
(let* ([settings (send definitions-text get-next-settings)] (let* ([settings (send definitions-text get-next-settings)]
[language (drracket:language-configuration:language-settings-language settings)]) [language (drracket:language-configuration:language-settings-language settings)])
(send func-defs-canvas language-changed language (or (toolbar-is-left?) (toolbar-is-right?))) (send func-defs-canvas language-changed language (or (toolbar-is-left?)
(toolbar-is-right?)))
(send language-message set-yellow/lang (send language-message set-yellow/lang
(not (send definitions-text this-and-next-language-the-same?)) (not (send definitions-text this-and-next-language-the-same?))
(string-append (send language get-language-name) (string-append (send language get-language-name)
(if (send language default-settings? (if (send language default-settings?
(drracket:language-configuration:language-settings-settings settings)) (drracket:language-configuration:language-settings-settings
settings))
"" ""
(string-append " " (string-constant custom))))) (string-append " " (string-constant custom)))))
(when (is-a? language-specific-menu menu%) (when (is-a? language-specific-menu menu%)
@ -2216,7 +2227,8 @@ module browser threading seems wrong.
(label (drracket:modes:mode-name mode)) (label (drracket:modes:mode-name mode))
(parent menu) (parent menu)
(callback (callback
(λ (_1 _2) (send definitions-text set-current-mode mode))))]) (λ (_1 _2) (send definitions-text set-current-mode
mode))))])
(when (send definitions-text is-current-mode? mode) (when (send definitions-text is-current-mode? mode)
(send item check #t)))) (send item check #t))))
(drracket:modes:get-modes)))))) (drracket:modes:get-modes))))))
@ -2928,7 +2940,8 @@ module browser threading seems wrong.
(set! interactions-shown? is?) (set! interactions-shown? is?)
(set! definitions-shown? ds?) (set! definitions-shown? ds?)
(update-shown) (update-shown)
(reflow-container) ;; without this one, the percentages in the resizable-panel are not up to date with the children (reflow-container) ;; without this one, the percentages in the
;; resizable-panel are not up to date with the children
(fix-up-canvas-numbers definitions-text vd #f) (fix-up-canvas-numbers definitions-text vd #f)
(fix-up-canvas-numbers interactions-text vi #t) (fix-up-canvas-numbers interactions-text vi #t)
(reflow-container) (reflow-container)
@ -3211,7 +3224,8 @@ module browser threading seems wrong.
(if (send cb get-value) (if (send cb get-value)
(send module-browser-pb show-visible-paths key) (send module-browser-pb show-visible-paths key)
(send module-browser-pb remove-visible-paths key)) (send module-browser-pb remove-visible-paths key))
(preferences:set 'drracket:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))] (preferences:set 'drracket:module-browser:hide-paths
(send module-browser-pb get-hidden-paths)))]
[mk-checkbox [mk-checkbox
(λ (key label) (λ (key label)
(new check-box% (new check-box%
@ -3558,13 +3572,17 @@ module browser threading seems wrong.
[parent language-menu] [parent language-menu]
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))]) (update-settings ((teachpack-callbacks-add tp-callbacks)
settings
this)))])
(let ([mi (new menu:can-restore-menu-item% (let ([mi (new menu:can-restore-menu-item%
[label (string-constant clear-all-teachpacks-menu-item-label)] [label (string-constant clear-all-teachpacks-menu-item-label)]
[parent language-menu] [parent language-menu]
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])]) (update-settings
((teachpack-callbacks-remove-all tp-callbacks)
settings)))])])
(send mi enable (not (null? tp-names))) (send mi enable (not (null? tp-names)))
mi) mi)
@ -3574,7 +3592,9 @@ module browser threading seems wrong.
[parent language-menu] [parent language-menu]
[callback [callback
(λ (item evt) (λ (item evt)
(update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) (update-settings
((teachpack-callbacks-remove tp-callbacks)
settings name)))]))
tp-names))))] tp-names))))]
[else [else
(set! teachpack-items (set! teachpack-items
@ -3584,20 +3604,22 @@ module browser threading seems wrong.
[parent language-menu] [parent language-menu]
[callback [callback
(λ (_1 _2) (λ (_1 _2)
(message-box (string-constant drscheme) (message-box
(gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) (string-constant drscheme)
(apply (gui-utils:format-literal-label
string-append (string-constant teachpacks-only-in-languages)
(reverse (apply
(filter string-append
values (reverse
(map (λ (l) (filter
(and values
(send l capability-value 'drscheme:teachpack-menu-items) (map (λ (l)
(format "\n ~a" (send l get-language-name)))) (and
(drracket:language-configuration:get-languages)))))) (send l capability-value 'drscheme:teachpack-menu-items)
this (format "\n ~a" (send l get-language-name))))
#:dialog-mixin frame:focus-table-mixin))])))]))) (drracket:language-configuration:get-languages))))))
this
#:dialog-mixin frame:focus-table-mixin))])))])))
(define/private (initialize-menus) (define/private (initialize-menus)
(let* ([mb (get-menu-bar)] (let* ([mb (get-menu-bar)]
@ -3667,6 +3689,7 @@ module browser threading seems wrong.
(* 1024 1024 num)) (* 1024 1024 num))
(send interactions-text set-custodian-limit (send interactions-text set-custodian-limit
(* 1024 1024 num))]))))])) (* 1024 1024 num))]))))]))
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
(label (string-constant clear-error-highlight-menu-item-label)) (label (string-constant clear-error-highlight-menu-item-label))
(parent language-specific-menu) (parent language-specific-menu)
@ -3684,6 +3707,67 @@ module browser threading seems wrong.
[ints (send tab get-ints)]) [ints (send tab get-ints)])
(send item enable (or (send ints get-error-ranges) (send item enable (or (send ints get-error-ranges)
(send tab get-test-coverage-info-visible?))))))) (send tab get-test-coverage-info-visible?)))))))
;; find-before-and-after : nat -> (values (or/c srcloc #f) (or/c srcloc #f) (listof srcloc))
;;
;; returns the source locations from the error ranges that are before and
;; after get-start-position, or #f if the insertion point is before
;; all of them or after all of them, respectively
;; also returns the sorted list of all srclocs
;;
;; this doesn't work properly when the positions are in embedded editor
;; (but it doesn't crash; it just has a strange notion of before and after)
(define (find-before-and-after)
(define tab (get-current-tab))
(define pos (send (send tab get-defs) get-start-position))
(define ranges (send (send tab get-ints) get-error-ranges))
(define sorted (sort ranges < #:key srcloc-position))
(let loop ([before #f]
[lst sorted])
(cond
[(null? lst)
(values before #f sorted)]
[else
(define fst (car lst))
(cond
[(= pos (- (srcloc-position fst) 1))
(values before
(if (null? (cdr lst))
#f
(cadr lst))
sorted)]
[(< pos (- (srcloc-position fst) 1))
(values before fst sorted)]
[else (loop (car lst) (cdr lst))])])))
(define (jump-to-source-loc srcloc)
(define ed (srcloc-source srcloc))
(send ed set-position (- (srcloc-position srcloc) 1))
(send ed set-caret-owner #f 'global))
(new menu:can-restore-menu-item%
(label (string-constant jump-to-next-error-highlight-menu-item-label))
(parent language-specific-menu)
(shortcut #\.)
(callback (λ (_1 _2) (jump-to-next-error-loc)))
(demand-callback
(λ (item)
(let* ([tab (get-current-tab)]
[ints (send tab get-ints)])
(send item enable (send ints get-error-ranges))))))
(new menu:can-restore-menu-item%
(label (string-constant jump-to-prev-error-highlight-menu-item-label))
(parent language-specific-menu)
(shortcut (if (eq? (system-type) 'macosx) #\. #\,))
(shortcut-prefix (if (eq? (system-type) 'macosx)
(cons 'shift (get-default-shortcut-prefix))
(get-default-shortcut-prefix)))
(callback (λ (_1 _2) (jump-to-previous-error-loc)))
(demand-callback
(λ (item)
(let* ([tab (get-current-tab)]
[ints (send tab get-ints)])
(send item enable (send ints get-error-ranges))))))
(make-object separator-menu-item% language-specific-menu) (make-object separator-menu-item% language-specific-menu)
(make-object menu:can-restore-menu-item% (make-object menu:can-restore-menu-item%
(string-constant create-executable-menu-item-label) (string-constant create-executable-menu-item-label)
@ -3816,14 +3900,14 @@ module browser threading seems wrong.
(λ () (λ ()
(let ([edit (get-edit-target-object)]) (let ([edit (get-edit-target-object)])
(when edit (when edit
(let ([language-settings (send definitions-text get-next-settings)]) (define language-settings (send definitions-text get-next-settings))
(let-values ([(comment-prefix comment-character) (define-values(comment-prefix comment-character)
(if language-settings (if language-settings
(send (drracket:language-configuration:language-settings-language (send (drracket:language-configuration:language-settings-language
language-settings) language-settings)
get-comment-character) get-comment-character)
(values ";" #\;))]) (values ";" #\;)))
(insert-large-letters comment-prefix comment-character edit this))))))] (insert-large-letters comment-prefix comment-character edit this))))]
[c% (get-menu-item%)]) [c% (get-menu-item%)])
(frame:add-snip-menu-items (frame:add-snip-menu-items
@ -3892,6 +3976,45 @@ module browser threading seems wrong.
(frame:reorder-menus this))) (frame:reorder-menus this)))
(define/public (jump-to-previous-error-loc)
(define-values (before after sorted) (find-before-and-after))
(unless (null? sorted)
(jump-to-source-loc (or before (last sorted)))))
(define/public (jump-to-next-error-loc)
(define-values (before after sorted) (find-before-and-after))
(unless (null? sorted)
(jump-to-source-loc (or after (car sorted)))))
(define/private (find-before-and-after)
(define tab (get-current-tab))
(define pos (send (send tab get-defs) get-start-position))
(define ranges (or (send (send tab get-ints) get-error-ranges) '()))
(define sorted (sort ranges < #:key srcloc-position))
(let loop ([before #f]
[lst sorted])
(cond
[(null? lst)
(values before #f sorted)]
[else
(define fst (car lst))
(cond
[(= pos (- (srcloc-position fst) 1))
(values before
(if (null? (cdr lst))
#f
(cadr lst))
sorted)]
[(< pos (- (srcloc-position fst) 1))
(values before fst sorted)]
[else (loop (car lst) (cdr lst))])])))
(define/private (jump-to-source-loc srcloc)
(define ed (srcloc-source srcloc))
(send ed set-position (- (srcloc-position srcloc) 1))
(send ed set-caret-owner #f 'global))
; ;
; ;
; ;
@ -4052,7 +4175,9 @@ module browser threading seems wrong.
(let-values ([(cw ch) (send c get-client-size)]) (let-values ([(cw ch) (send c get-client-size)])
(send dc set-font small-control-font) (send dc set-font small-control-font)
(send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))])) (send dc draw-text on-string 0 (- (/ ch 2) (/ th 2)))))))]))
(define-values (tw th ta td) (send (send color-status-canvas get-dc) get-text-extent on-string small-control-font)) (define-values (tw th ta td)
(send (send color-status-canvas get-dc) get-text-extent
on-string small-control-font))
(send color-status-canvas min-width (inexact->exact (ceiling tw))) (send color-status-canvas min-width (inexact->exact (ceiling tw)))
color-status-canvas))) color-status-canvas)))
(define color-valid? #t) (define color-valid? #t)
@ -4164,7 +4289,9 @@ module browser threading seems wrong.
(set-color-status! (send definitions-text is-lexer-valid?)) (set-color-status! (send definitions-text is-lexer-valid?))
(send definitions-canvas focus))) (send definitions-canvas focus)))
;; get-define-popup-name : (or/c #f (cons/c string? string?) (list/c string? string? string)) boolean -> (or/c #f string?) ;; get-define-popup-name : (or/c #f (cons/c string? string?) (list/c string? string? string))
;; boolean
;; -> (or/c #f string?)
(define (get-define-popup-name info vertical?) (define (get-define-popup-name info vertical?)
(and info (and info
(if vertical? (if vertical?
@ -4308,7 +4435,8 @@ module browser threading seems wrong.
(define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)]))
(define rb (new radio-box% (define rb (new radio-box%
[label #f] [label #f]
[choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))] [choices (list (string-constant limit-memory-unlimited)
(string-constant limit-memory-limited))]
[callback (λ (a b) (grayizie))] [callback (λ (a b) (grayizie))]
[parent outer-hp])) [parent outer-hp]))
@ -4597,7 +4725,9 @@ module browser threading seems wrong.
[label (read-line (open-input-string desc))] [label (read-line (open-input-string desc))]
[parent vp] [parent vp]
[stretchable-width #t] [stretchable-width #t]
[font (send (send (editor:get-standard-style-list) find-named-style "Standard") get-font)])))) [font (send (send (editor:get-standard-style-list) find-named-style
"Standard")
get-font)]))))
(define msg (new message% (define msg (new message%
[stretchable-width #t] [stretchable-width #t]
[label (string-append (lookup 'component "<<unknown component>>") [label (string-append (lookup 'component "<<unknown component>>")
@ -4624,7 +4754,8 @@ module browser threading seems wrong.
(send saved-bug-reports-window end-container-sequence)) (send saved-bug-reports-window end-container-sequence))
(define (forget-saved-bug-report item) (define (forget-saved-bug-report item)
(preferences:set 'drracket:saved-bug-reports (remove item (preferences:get 'drracket:saved-bug-reports)))) (preferences:set 'drracket:saved-bug-reports
(remove item (preferences:get 'drracket:saved-bug-reports))))
(define (show-saved-bug-reports-window) (define (show-saved-bug-reports-window)
(init-saved-bug-reports-window) (init-saved-bug-reports-window)

2
collects/string-constants/private/english-string-constants.rkt
View File

@ -932,6 +932,8 @@ please adhere to these guidelines:
(limit-memory-megabytes "Megabytes") (limit-memory-megabytes "Megabytes")
(clear-error-highlight-menu-item-label "Clear Error Highlight") (clear-error-highlight-menu-item-label "Clear Error Highlight")
(clear-error-highlight-item-help-string "Removes the pink error highlighting") (clear-error-highlight-item-help-string "Removes the pink error highlighting")
(jump-to-next-error-highlight-menu-item-label "Jump to Next Error Highlight")
(jump-to-prev-error-highlight-menu-item-label "Jump to Previous Error Highlight")
(reindent-menu-item-label "&Reindent") (reindent-menu-item-label "&Reindent")
(reindent-all-menu-item-label "Reindent &All") (reindent-all-menu-item-label "Reindent &All")
(semicolon-comment-out-menu-item-label "&Comment Out with Semicolons") (semicolon-comment-out-menu-item-label "&Comment Out with Semicolons")