From 13e16d2b12a6db4ba00ac886fb1c2d33421d1cd6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 20 Sep 2011 16:57:13 -0500 Subject: [PATCH] add preferences for displaying error messages from online expansion also improved the highlighting in the margin by invalidating only the region of the editor that actually needs redrawing --- collects/drracket/private/drsig.rkt | 3 +- collects/drracket/private/expanding-place.rkt | 15 +- collects/drracket/private/main.rkt | 13 +- collects/drracket/private/module-language.rkt | 157 ++++++++++++++---- .../private/english-string-constants.rkt | 10 ++ 5 files changed, 159 insertions(+), 39 deletions(-) diff --git a/collects/drracket/private/drsig.rkt b/collects/drracket/private/drsig.rkt index a1a4a0313c..2650ebe823 100644 --- a/collects/drracket/private/drsig.rkt +++ b/collects/drracket/private/drsig.rkt @@ -95,7 +95,8 @@ (define-signature drracket:module-language/int^ extends drracket:module-language^ (module-language-online-expand-text-mixin module-language-online-expand-frame-mixin - module-language-online-expand-tab-mixin)) + module-language-online-expand-tab-mixin + initialize-prefs-panel)) (define-signature drracket:module-language-tools-cm^ (frame-mixin diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt index 203746dd81..09464aaa57 100644 --- a/collects/drracket/private/expanding-place.rkt +++ b/collects/drracket/private/expanding-place.rkt @@ -170,15 +170,16 @@ (cond [(exn:access? exn) (vector 'access-violation (exn-message exn))] - [(and (exn:fail:read? exn) - (andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source)) - (exn:fail:read-srclocs exn))) - ;; figure the syntax colorer can help with these - ;; and show just show a subtle thing instead of the full error - (vector 'reader-in-defs-error (exn-message exn))] [else (vector - 'exn + (cond + [(and (exn:fail:read? exn) + (andmap (λ (srcloc) (equal? (srcloc-source srcloc) the-source)) + (exn:fail:read-srclocs exn))) + 'reader-in-defs-error] + [(regexp-match #rx"expand: unbound identifier" (exn-message exn)) + 'exn:variable] + [else 'exn]) (trim-message (if (exn? exn) (regexp-replace* #rx"[ \t]*\n[ \t]*" (exn-message exn) " ") diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 692531afc5..bc4ac70b06 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -526,7 +526,16 @@ (or settings (send lang default-settings))))))))) (preferences:set-default 'drracket:online-compilation-default-off #f boolean?) - + (preferences:set-default 'drracket:online-expansion:read-in-defs-errors + 'corner + (or/c 'margin 'gold 'corner)) + (preferences:set-default 'drracket:online-expansion:variable-errors + 'margin + (or/c 'margin 'gold)) + (preferences:set-default 'drracket:online-expansion:other-errors + 'margin + (or/c 'margin 'gold)) + (drr:set-default 'drracket:multi-file-search:recur? #t boolean?) (drr:set-default 'drracket:multi-file-search:filter? #t boolean?) (drr:set-default 'drracket:multi-file-search:filter-regexp "\\.(rkt.?|scrbl|ss|scm)$" string?) @@ -652,7 +661,7 @@ drracket:debug:test-coverage-off-style-name (string-constant test-coverage-off)))) - +(drracket:module-language:initialize-prefs-panel) (let* ([find-frame (λ (item) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 0101ccb3ac..314cb2a436 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1276,27 +1276,22 @@ (set! compilation-out-of-date? #f) (case (vector-ref res 0) [(exn) - (define tlw (send (get-tab) get-frame)) - (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-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)] + (case (preferences:get 'drracket:online-expansion:other-errors) + [(margin) (show-error-in-margin res)] + [(gold) (show-error-as-highlighted-regions res)])] + [(exn:variable) + (case (preferences:get 'drracket:online-expansion:variable-errors) + [(margin) (show-error-in-margin res)] + [(gold) (show-error-as-highlighted-regions res)])] + [(reader-in-defs-error) + (case (preferences:get 'drracket:online-expansion:read-in-defs-errors) + [(margin) (show-error-in-margin res)] + [(gold) (show-error-as-highlighted-regions res)] + [(corner) (show-error-as-parens-in-corner res)])] [(access-violation) (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1))) (clear-old-error) (reset-frame-expand-error)] - [(reader-in-defs-error) - (send (get-tab) show-bkg-running 'reader-in-defs-error - (gui-utils:format-literal-label "~a" (vector-ref res 1))) - (clear-old-error) - (reset-frame-expand-error)] [(abnormal-termination) (send (get-tab) show-bkg-running 'failed sc-abnormal-termination) (clear-old-error) @@ -1321,25 +1316,71 @@ [else (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)])) + (define/private (show-error-as-parens-in-corner res) + (send (get-tab) show-bkg-running 'reader-in-defs-error + (gui-utils:format-literal-label "~a" (vector-ref res 1))) + (clear-old-error) + (reset-frame-expand-error)) + + (define/private (show-error-in-margin res) + (define tlw (send (get-tab) get-frame)) + (send (get-tab) show-bkg-running 'nothing #f) + (set! error-message-str (vector-ref res 1)) + (set! error-message-srclocs (vector-ref res 2)) + (clear-old-error) + (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))) + (set-error-ranges-from-online-error-ranges (vector-ref res 2)) + (invalidate-online-error-ranges) + (update-frame-expand-error)) + + (define/private (show-error-as-highlighted-regions res) + (define tlw (send (get-tab) get-frame)) + (send (get-tab) show-bkg-running 'nothing #f) + (set! error-message-str (vector-ref res 1)) + (set! error-message-srclocs (vector-ref res 2)) + (clear-old-error) + (set! online-highlighted-errors + (for/list ([range (in-list (vector-ref res 2))]) + (define pos (vector-ref range 0)) + (define span (vector-ref range 1)) + (highlight-range (- pos 1) (+ pos span -1) "gold"))) + (set-error-ranges-from-online-error-ranges (vector-ref res 2)) + (update-frame-expand-error)) (define online-error-ranges '()) + (define online-highlighted-errors '()) + (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))) + (unless (equal? online-error-ranges rngs) + (invalidate-online-error-ranges) + (set! online-error-ranges rngs) + (invalidate-online-error-ranges))) + + (define/private (set-error-ranges-from-online-error-ranges rngs) + (define srclocs (for/list ([range (in-list rngs)]) + (define pos (vector-ref range 0)) + (define span (vector-ref range 1)) + (srcloc this #f #f pos span))) + (send (send (get-tab) get-ints) set-error-ranges srclocs)) + (define/private (clear-old-error) + (for ([cleanup-thunk (in-list online-highlighted-errors)]) + (cleanup-thunk)) (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-online-error-ranges '()) - (invalidate-bitmap-cache 0 0 'display-end 'display-end)) + (invalidate-online-error-ranges) + (set-online-error-ranges '())) + + (define/private (invalidate-online-error-ranges) + (for ([an-error-range (in-list online-error-ranges)]) + (define-values (x y w h) (get-box an-error-range)) + (invalidate-bitmap-cache x y 'display-end h))) (define byt (box 0.0)) (define byb (box 0.0)) @@ -1544,4 +1585,62 @@ (let ([settings (send (send tlw get-definitions-text) get-next-settings)]) (and (is-a? (drracket:language-configuration:language-settings-language settings) module-language<%>) - (drracket:language-configuration:language-settings-settings settings)))))) + (drracket:language-configuration:language-settings-settings settings))))) + + + (define (initialize-prefs-panel) + (preferences:add-panel + (string-constant online-expansion) + (λ (parent) + (define parent-vp (new vertical-panel% + [parent parent] + [alignment '(center top)])) + (define vp (new vertical-panel% + [parent parent-vp] + [stretchable-width #f] + [stretchable-height #f] + [alignment '(left center)])) + + (define ((make-callback pref-sym) choice evt) + (preferences:set pref-sym (index->pref (send choice get-selection)))) + (define read-choice + (new choice% + [parent vp] + [label (string-constant online-expansion-show-read-errors-as)] + [callback (make-callback 'drracket:online-expansion:read-in-defs-errors)] + [choices (list (string-constant online-expansion-error-margin) + (string-constant online-expansion-error-gold-highlight) + (string-constant online-expansion-error-in-corner))])) + (define var-choice + (new choice% + [parent vp] + [label (string-constant online-expansion-show-variable-errors-as)] + [callback (make-callback 'drracket:online-expansion:variable-errors)] + [choices (list (string-constant online-expansion-error-margin) + (string-constant online-expansion-error-gold-highlight))])) + (define other-choice + (new choice% + [parent vp] + [label (string-constant online-expansion-show-other-errors-as)] + [callback (make-callback 'drracket:online-expansion:other-errors)] + [choices (list (string-constant online-expansion-error-margin) + (string-constant online-expansion-error-gold-highlight))])) + (define (connect-to-prefs choice pref-sym) + (preferences:add-callback + pref-sym + (λ (pref-sym nv) (send choice set-selection (pref->index nv)))) + (send choice set-selection (pref->index (preferences:get pref-sym)))) + (define (index->pref n) + (case n + [(0) 'margin] + [(1) 'gold] + [(2) 'corner])) + (define (pref->index p) + (case p + [(margin) 0] + [(gold) 1] + [(corner) 2])) + (connect-to-prefs read-choice 'drracket:online-expansion:read-in-defs-errors) + (connect-to-prefs var-choice 'drracket:online-expansion:variable-errors) + (connect-to-prefs other-choice 'drracket:online-expansion:other-errors) + parent-vp)))) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 51e0faf4cd..81cf8c7a28 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -225,6 +225,16 @@ please adhere to these guidelines: (jump-to-error "Jump to Error") (online-expansion-is-disabled "Online expansion is disabled") + ;; the online expansion preferences pane + (online-expansion "Online expansion") ;; title of prefs pane + ; the different kinds of errors + (online-expansion-show-read-errors-as "Show read-level errors") + (online-expansion-show-variable-errors-as "Show unbound identifier errors") + (online-expansion-show-other-errors-as "Show other errors") + ; locations the errors can be shown + (online-expansion-error-in-corner "in the corner of the window") + (online-expansion-error-gold-highlight "with gold highlighting") + (online-expansion-error-margin "in the margin") ;;; info bar at botttom of drscheme frame (collect-button-label "GC") (read-only "Read only")