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

add preferences for displaying error messages from online expansion

Browse Source 
also improved the highlighting in the margin by invalidating only the region
of the editor that actually needs redrawing
This commit is contained in:
Robby Findler 2011-09-20 16:57:13 -05:00
parent 7e27cc5331
commit 13e16d2b12
5 changed files with 159 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drracket/private/drsig.rkt
View File

@ -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

15
collects/drracket/private/expanding-place.rkt
View File

@ -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) " ")

13
collects/drracket/private/main.rkt
View File

@ -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)

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

@ -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))))

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

@ -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")