From 252db20c85c9879ac410264a027bb9f45e1a8d90 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 Sep 2011 22:47:47 -0500 Subject: [PATCH] add menus and keybindings for jumping around to the errors in the defs window also a little line-length shrinking --- .../drracket/private/local-member-names.rkt | 6 +- collects/drracket/private/module-language.rkt | 38 +-- collects/drracket/private/rep.rkt | 209 +++++++++-------- collects/drracket/private/unit.rkt | 219 ++++++++++++++---- .../private/english-string-constants.rkt | 2 + 5 files changed, 318 insertions(+), 156 deletions(-) diff --git a/collects/drracket/private/local-member-names.rkt b/collects/drracket/private/local-member-names.rkt index 7927111b61..742c8e6545 100644 --- a/collects/drracket/private/local-member-names.rkt +++ b/collects/drracket/private/local-member-names.rkt @@ -12,4 +12,8 @@ ;; from module-language-tools.rkt (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) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index ac130af766..2a72047dbe 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1271,12 +1271,12 @@ (send (get-tab) show-bkg-running 'nothing #f) (set! error-message-str (vector-ref res 1)) (set! error-message-srclocs (vector-ref res 2)) - (set! error-ranges - (for/list ([range (in-list (vector-ref res 2))]) - (define pos (vector-ref range 0)) - (define span (vector-ref range 1)) - (error-range (- pos 1) (+ pos span -1) #f))) - ;; should really only invalidate the appropriate region here (and in clear-error-ranges) + (set-online-error-ranges + (for/list ([range (in-list (vector-ref res 2))]) + (define pos (vector-ref range 0)) + (define span (vector-ref range 1)) + (error-range (- pos 1) (+ pos span -1) #f))) + ;; should really only invalidate the appropriate region here (and in clear-online-error-ranges) (invalidate-bitmap-cache 0 0 'display-end 'display-end) (update-frame-expand-error)] [(access-violation) @@ -1313,13 +1313,23 @@ (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) - (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) ((error-range-clear-highlight an-error-range)) (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)) (define byt (box 0.0)) @@ -1349,7 +1359,7 @@ .5 .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)) (send path move-to (+ dx x2) (+ dy y2)) @@ -1373,7 +1383,7 @@ (cond [(or (send evt moving?) (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)) (cond [(and (<= x1 mx x2) @@ -1390,14 +1400,14 @@ (set-error-range-clear-highlight! an-error-range #f))])) (super on-event evt)] [(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) ((error-range-clear-highlight an-error-range)) (set-error-range-clear-highlight! an-error-range #f))) (super on-event evt)] [(send evt button-down? 'left) (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)) (when (and (<= x1 mx x2) (<= y2 my y3)) @@ -1526,7 +1536,7 @@ (compile-lock->parallel-lock-client module-language-compile-lock (current-custodian))) - + ;; in-module-language : top-level-window<%> -> module-language-settings or #f (define (in-module-language tlw) (and tlw diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 975a0e6b2c..bc5f4cb97a 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -28,6 +28,7 @@ TODO framework browser/external "drsig.rkt" + "local-member-names.rkt" ;; the dynamic-require below loads this module, ;; 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 "prev-tab" (λ (frame) (send frame prev-tab))) (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 "f1" "search-help-desk") @@ -591,6 +603,10 @@ TODO ;; error-ranges : (union false? (cons (list file number number) (listof (list file number number)))) (define error-ranges #f) (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-error-arrows-callback void) (define/public (reset-error-ranges) @@ -615,105 +631,104 @@ TODO ;; (union #f (listof srcloc)) ;; -> (void) (define/public (highlight-errors raw-locs [raw-error-arrows #f]) - (let* ([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))))] - [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))]) + (set-error-ranges raw-locs) + (define locs (get-error-ranges)) ;; calling set-error-range cleans up the locs + (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))) + + (reset-highlighting) + + (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 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))) + (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))) - (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, - ;; make sure it is visible - (let ([tlw (send first-file get-top-level-window)]) - (when (is-a? tlw drracket:unit:frame<%>) - (send tlw ensure-defs-shown)))) - - (send first-file set-caret-owner (get-focus-snip) 'global))))) + (when (eq? first-file definitions-text) + ;; when we're highlighting something in the defs window, + ;; make sure it is visible + (let ([tlw (send first-file get-top-level-window)]) + (when (is-a? tlw drracket:unit:frame<%>) + (send tlw ensure-defs-shown)))) + + (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/public (reset-highlighting) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 8d8afe6504..583ec63ab2 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -1433,7 +1433,9 @@ module browser threading seems wrong. (remq logger-panel l)])))] [else (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 (new tab-panel% [choices (list (string-constant logging-all) @@ -1443,7 +1445,8 @@ module browser threading seems wrong. [style '(no-border)] [callback (λ (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))])) (new button% [label (string-constant hide-log)] [callback (λ (x y) (send current-tab hide-log))] @@ -1554,7 +1557,10 @@ module browser threading seems wrong. (new message% [parent planet-status-panel] [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 (new button% [font small-control-font] @@ -1688,10 +1694,11 @@ module browser threading seems wrong. (λ (exn) (message-box (string-constant drscheme) - (gui-utils:format-literal-label (string-constant error-erasing-log-directory) - (if (exn? exn) - (format "~a" (exn-message exn)) - (format "~s" exn))) + (gui-utils:format-literal-label + (string-constant error-erasing-log-directory) + (if (exn? exn) + (format "~a" (exn-message exn)) + (format "~s" exn))) this #:dialog-mixin frame:focus-table-mixin) #f)]) @@ -1762,7 +1769,8 @@ module browser threading seems wrong. (preferences:set 'drracket:toolbar-state new-state) (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-right) (change-toolbar-state (cons #f 'right))) (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))] [(is-a? obj switchable-button%) (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)))] [else (void)]))) @@ -1961,12 +1970,14 @@ module browser threading seems wrong. (define/public (language-changed) (let* ([settings (send definitions-text get-next-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 (not (send definitions-text this-and-next-language-the-same?)) (string-append (send language get-language-name) (if (send language default-settings? - (drracket:language-configuration:language-settings-settings settings)) + (drracket:language-configuration:language-settings-settings + settings)) "" (string-append " " (string-constant custom))))) (when (is-a? language-specific-menu menu%) @@ -2216,7 +2227,8 @@ module browser threading seems wrong. (label (drracket:modes:mode-name mode)) (parent menu) (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) (send item check #t)))) (drracket:modes:get-modes)))))) @@ -2928,7 +2940,8 @@ module browser threading seems wrong. (set! interactions-shown? is?) (set! definitions-shown? ds?) (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 interactions-text vi #t) (reflow-container) @@ -3211,7 +3224,8 @@ module browser threading seems wrong. (if (send cb get-value) (send module-browser-pb show-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 (λ (key label) (new check-box% @@ -3558,13 +3572,17 @@ module browser threading seems wrong. [parent language-menu] [callback (λ (_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% [label (string-constant clear-all-teachpacks-menu-item-label)] [parent language-menu] [callback (λ (_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))) mi) @@ -3574,7 +3592,9 @@ module browser threading seems wrong. [parent language-menu] [callback (λ (item evt) - (update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))])) + (update-settings + ((teachpack-callbacks-remove tp-callbacks) + settings name)))])) tp-names))))] [else (set! teachpack-items @@ -3584,20 +3604,22 @@ module browser threading seems wrong. [parent language-menu] [callback (λ (_1 _2) - (message-box (string-constant drscheme) - (gui-utils:format-literal-label (string-constant teachpacks-only-in-languages) - (apply - string-append - (reverse - (filter - values - (map (λ (l) - (and - (send l capability-value 'drscheme:teachpack-menu-items) - (format "\n ~a" (send l get-language-name)))) - (drracket:language-configuration:get-languages)))))) - this - #:dialog-mixin frame:focus-table-mixin))])))]))) + (message-box + (string-constant drscheme) + (gui-utils:format-literal-label + (string-constant teachpacks-only-in-languages) + (apply + string-append + (reverse + (filter + values + (map (λ (l) + (and + (send l capability-value 'drscheme:teachpack-menu-items) + (format "\n ~a" (send l get-language-name)))) + (drracket:language-configuration:get-languages)))))) + this + #:dialog-mixin frame:focus-table-mixin))])))]))) (define/private (initialize-menus) (let* ([mb (get-menu-bar)] @@ -3667,6 +3689,7 @@ module browser threading seems wrong. (* 1024 1024 num)) (send interactions-text set-custodian-limit (* 1024 1024 num))]))))])) + (new menu:can-restore-menu-item% (label (string-constant clear-error-highlight-menu-item-label)) (parent language-specific-menu) @@ -3684,6 +3707,67 @@ module browser threading seems wrong. [ints (send tab get-ints)]) (send item enable (or (send ints get-error-ranges) (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 menu:can-restore-menu-item% (string-constant create-executable-menu-item-label) @@ -3816,14 +3900,14 @@ module browser threading seems wrong. (λ () (let ([edit (get-edit-target-object)]) (when edit - (let ([language-settings (send definitions-text get-next-settings)]) - (let-values ([(comment-prefix comment-character) - (if language-settings - (send (drracket:language-configuration:language-settings-language - language-settings) - get-comment-character) - (values ";" #\;))]) - (insert-large-letters comment-prefix comment-character edit this))))))] + (define language-settings (send definitions-text get-next-settings)) + (define-values(comment-prefix comment-character) + (if language-settings + (send (drracket:language-configuration:language-settings-language + language-settings) + get-comment-character) + (values ";" #\;))) + (insert-large-letters comment-prefix comment-character edit this))))] [c% (get-menu-item%)]) (frame:add-snip-menu-items @@ -3892,6 +3976,45 @@ module browser threading seems wrong. (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)]) (send dc set-font small-control-font) (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))) color-status-canvas))) (define color-valid? #t) @@ -4164,7 +4289,9 @@ module browser threading seems wrong. (set-color-status! (send definitions-text is-lexer-valid?)) (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?) (and info (if vertical? @@ -4308,7 +4435,8 @@ module browser threading seems wrong. (define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)])) (define rb (new radio-box% [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))] [parent outer-hp])) @@ -4597,7 +4725,9 @@ module browser threading seems wrong. [label (read-line (open-input-string desc))] [parent vp] [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% [stretchable-width #t] [label (string-append (lookup 'component "<>") @@ -4624,7 +4754,8 @@ module browser threading seems wrong. (send saved-bug-reports-window end-container-sequence)) (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) (init-saved-bug-reports-window) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 372b608026..51e0faf4cd 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -932,6 +932,8 @@ please adhere to these guidelines: (limit-memory-megabytes "Megabytes") (clear-error-highlight-menu-item-label "Clear Error Highlight") (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-all-menu-item-label "Reindent &All") (semicolon-comment-out-menu-item-label "&Comment Out with Semicolons")