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

add an option to disable the blue arrow things

Browse Source 
(and thus the blue boxes) entirely

closes PR 13761
This commit is contained in:
Robby Findler 2013-06-29 07:09:51 -05:00
parent c20933119e
commit ceca1e0ba7
3 changed files with 121 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt
View File

@ -21,6 +21,7 @@
(define sc-read-more... (string-constant sc-read-more...)) (define sc-read-more... (string-constant sc-read-more...))
(preferences:set-default 'drracket:syncheck:contracts-locked? #f boolean?) (preferences:set-default 'drracket:syncheck:contracts-locked? #f boolean?)
(preferences:set-default 'drracket:syncheck:show-blueboxes? #t boolean?)
(define corner-radius 48) (define corner-radius 48)
(define blue-box-color (make-object color% #xE8 #xE8 #xFF)) (define blue-box-color (make-object color% #xE8 #xE8 #xFF))
@ -129,66 +130,67 @@
(inherit get-dc get-client-size get-editor (inherit get-dc get-client-size get-editor
horizontal-inset vertical-inset) horizontal-inset vertical-inset)
(define/override (on-paint) (define/override (on-paint)
(define e (get-editor)) (when (preferences:get 'drracket:syncheck:show-blueboxes?)
(when e (define e (get-editor))
(define dc (get-dc)) (when e
(define-values (cw ch) (get-client-size)) (define dc (get-dc))
(define the-strs (send e get-current-strs)) (define-values (cw ch) (get-client-size))
(cond (define the-strs (send e get-current-strs))
[(and (send e get-show-docs?) the-strs) (cond
(define hi (horizontal-inset)) [(and (send e get-show-docs?) the-strs)
(define vi (vertical-inset)) (define hi (horizontal-inset))
(define font (send dc get-font)) (define vi (vertical-inset))
(define pen (send dc get-pen)) (define font (send dc get-font))
(define brush (send dc get-brush)) (define pen (send dc get-pen))
(define smoothing (send dc get-smoothing)) (define brush (send dc get-brush))
(define std (send (send e get-style-list) find-named-style "Standard")) (define smoothing (send dc get-smoothing))
(when std (send dc set-font (send std get-font))) (define std (send (send e get-style-list) find-named-style "Standard"))
(define-values (box-width box-height label-overlap?) (when std (send dc set-font (send std get-font)))
(get-blue-box-size dc (send e get-style-list) the-strs)) (define-values (box-width box-height label-overlap?)
(send dc set-brush blue-box-color 'solid) (get-blue-box-size dc (send e get-style-list) the-strs))
(send dc set-pen "black" 1 'transparent) (send dc set-brush blue-box-color 'solid)
(send dc draw-rectangle (- cw box-width) 0 box-width box-height) (send dc set-pen "black" 1 'transparent)
(send dc set-smoothing 'aligned) (send dc draw-rectangle (- cw box-width) 0 box-width box-height)
(send dc set-smoothing 'aligned)
;; most of the time (unless the user is
;; resizing the window) we don't really ;; most of the time (unless the user is
;; need a new clipping region, so just ;; resizing the window) we don't really
;; make a cache of size 1, keyed by the ;; need a new clipping region, so just
;; client width, height, and vertical and ;; make a cache of size 1, keyed by the
;; horizontal insets. ;; client width, height, and vertical and
(unless (and (equal? cw docs-ec-last-cw) ;; horizontal insets.
(equal? ch docs-ec-last-ch) (unless (and (equal? cw docs-ec-last-cw)
(equal? hi docs-ec-last-hi) (equal? ch docs-ec-last-ch)
(equal? vi docs-ec-last-vi)) (equal? hi docs-ec-last-hi)
(set! docs-ec-last-cw cw) (equal? vi docs-ec-last-vi))
(set! docs-ec-last-ch ch) (set! docs-ec-last-cw cw)
(set! docs-ec-last-hi hi) (set! docs-ec-last-ch ch)
(set! docs-ec-last-vi vi) (set! docs-ec-last-hi hi)
(define rgn1 (new region%)) (set! docs-ec-last-vi vi)
(define rgn2 (new region%)) (define rgn1 (new region%))
(define rgn3 (new region%)) (define rgn2 (new region%))
(define rgn4 (new region%)) (define rgn3 (new region%))
(send rgn1 set-rectangle 0 0 cw vi) (define rgn4 (new region%))
(send rgn2 set-rectangle (- cw hi) 0 hi ch) (send rgn1 set-rectangle 0 0 cw vi)
(send rgn3 set-rectangle 0 (- ch vi) cw vi) (send rgn2 set-rectangle (- cw hi) 0 hi ch)
(send rgn4 set-rectangle 0 0 hi ch) (send rgn3 set-rectangle 0 (- ch vi) cw vi)
(send rgn1 union rgn2) (send rgn4 set-rectangle 0 0 hi ch)
(send rgn1 union rgn3) (send rgn1 union rgn2)
(send rgn1 union rgn4) (send rgn1 union rgn3)
(set! docs-ec-clipping-region rgn1)) (send rgn1 union rgn4)
(set! docs-ec-clipping-region rgn1))
(define old-region (send dc get-clipping-region))
(send dc set-clipping-region docs-ec-clipping-region) (define old-region (send dc get-clipping-region))
(draw-blue-box-shadow dc (- cw box-width) 0 box-width box-height) (send dc set-clipping-region docs-ec-clipping-region)
(draw-blue-box-shadow dc (- cw box-width) 0 box-width box-height)
(send dc set-clipping-region old-region)
(send dc set-pen pen) (send dc set-clipping-region old-region)
(send dc set-brush brush) (send dc set-pen pen)
(send dc set-font font) (send dc set-brush brush)
(send dc set-smoothing smoothing)] (send dc set-font font)
[the-strs (send dc set-smoothing smoothing)]
(draw-closed dc cw 0)])) [the-strs
(draw-closed dc cw 0)])))
(super on-paint)) (super on-paint))
(super-new))) (super-new)))
@ -280,6 +282,12 @@
[the-strs [the-strs
(define size (+ corner-radius shadow-size)) (define size (+ corner-radius shadow-size))
(invalidate-bitmap-cache (max 0 (- br size)) (max 0 bt) size size)])))) (invalidate-bitmap-cache (max 0 (- br size)) (max 0 bt) size size)]))))
(define pref-changed-callback (λ (x y) (invalidate-blue-box-region)))
(preferences:add-callback
'drracket:syncheck:show-blueboxes?
pref-changed-callback
#t)
(define bx (box 0)) (define bx (box 0))
(define by (box 0)) (define by (box 0))
@ -303,25 +311,26 @@
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret) (super on-paint before? dc left top right bottom dx dy draw-caret)
(define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates)) (when (preferences:get 'drracket:syncheck:show-blueboxes?)
(when (and (not before?) br bt) (define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates))
(define canvas (get-canvas)) (when (and (not before?) br bt)
(define hi (send canvas horizontal-inset)) (define canvas (get-canvas))
(define vi (send canvas vertical-inset)) (define hi (send canvas horizontal-inset))
(cond (define vi (send canvas vertical-inset))
[(get-show-docs?) (cond
(draw-open dc dx dy [(get-show-docs?)
(get-style-list) (draw-open dc dx dy
the-strs (get-style-list)
br bt bmp-x bmp-y the-strs
mouse-in-blue-box? br bt bmp-x bmp-y
mouse-in-lock-icon? mouse-in-blue-box?
mouse-in-read-more? mouse-in-lock-icon?
locked? mouse-in-read-more?
locked?
left top right bottom)]
[the-strs left top right bottom)]
(draw-closed dc (+ dx br) (+ dy bt))]))) [the-strs
(draw-closed dc (+ dx br) (+ dy bt))]))))
;; get-box-upper-right-and-lock-coordinates ;; get-box-upper-right-and-lock-coordinates
;; : (or/c (-> (values #f #f #f #f) ;; : (or/c (-> (values #f #f #f #f)
@ -769,8 +778,12 @@
(new brush% (new brush%
[gradient [gradient
(new radial-gradient% (new radial-gradient%
[x0 (+ corner-radius shadow-size)] [y0 (+ corner-radius shadow-size)] [r0 corner-radius] [x0 (+ corner-radius shadow-size)]
[x1 (+ corner-radius shadow-size)] [y1 (+ corner-radius shadow-size)] [r1 (+ shadow-size corner-radius)] [y0 (+ corner-radius shadow-size)]
[r0 corner-radius]
[x1 (+ corner-radius shadow-size)]
[y1 (+ corner-radius shadow-size)]
[r1 (+ shadow-size corner-radius)]
[stops (list (list 0 (make-object color% 0 0 0 0)) [stops (list (list 0 (make-object color% 0 0 0 0))
(list 0 shadow-start-color) (list 0 shadow-start-color)
(list 1 shadow-end-color))])])) (list 1 shadow-end-color))])]))

41
pkgs/drracket/drracket/private/syncheck/gui.rkt
View File

@ -91,7 +91,10 @@ If the namespace does not, they are colored the unbound color.
(define (syncheck-add-to-online-expansion-prefs-panel vp) (define (syncheck-add-to-online-expansion-prefs-panel vp)
(preferences:add-check vp (preferences:add-check vp
'drracket:syncheck:show-arrows? 'drracket:syncheck:show-arrows?
(string-constant show-arrows-on-mouseover))) (string-constant show-arrows-on-mouseover))
(preferences:add-check vp
'drracket:syncheck:show-blueboxes?
(string-constant show-blueboxes)))
(define (syncheck-add-to-preferences-panel parent) (define (syncheck-add-to-preferences-panel parent)
(color-prefs:build-color-selection-panel parent (color-prefs:build-color-selection-panel parent
@ -212,7 +215,8 @@ If the namespace does not, they are colored the unbound color.
(define-struct (var-arrow arrow) (define-struct (var-arrow arrow)
(start-text start-pos-left start-pos-right (start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right end-text end-pos-left end-pos-right
actual? level require-arrow? name-dup?) ;; level is one of 'lexical, 'top-level, 'import actual? level require-arrow? name-dup?)
;; level is one of 'lexical, 'top-level, 'import
#:transparent) #:transparent)
(define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent)
@ -251,9 +255,12 @@ If the namespace does not, they are colored the unbound color.
(send the-brush-list find-or-create-brush "orchid" 'solid) (send the-brush-list find-or-create-brush "orchid" 'solid)
(send the-brush-list find-or-create-brush templ-color 'solid))) (send the-brush-list find-or-create-brush templ-color 'solid)))
(define (get-tail-pen white-on-black?) (send the-pen-list find-or-create-pen "orchid" 1 'solid)) (define (get-tail-pen white-on-black?)
(define (get-tacked-tail-brush white-on-black?) (send the-brush-list find-or-create-brush "orchid" 'solid)) (send the-pen-list find-or-create-pen "orchid" 1 'solid))
(define (get-untacked-brush white-on-black?) (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (get-tacked-tail-brush white-on-black?)
(send the-brush-list find-or-create-brush "orchid" 'solid))
(define (get-untacked-brush white-on-black?)
(send the-brush-list find-or-create-brush "WHITE" 'solid))
;; clearing-text-mixin : (mixin text%) ;; clearing-text-mixin : (mixin text%)
;; overrides methods that make sure the arrows go away appropriately. ;; overrides methods that make sure the arrows go away appropriately.
@ -396,7 +403,8 @@ If the namespace does not, they are colored the unbound color.
(define definition-targets (make-hash)) (define definition-targets (make-hash))
;; bindings-table : hash-table[(list text number number) -o> (setof (list text number number))] ;; bindings-table : hash-table[(list text number number)
;; -o> (setof (list text number number))]
;; this is a private field ;; this is a private field
(define bindings-table (make-hash)) (define bindings-table (make-hash))
@ -486,15 +494,18 @@ If the namespace does not, they are colored the unbound color.
(define/private (find-char-box text left-pos right-pos) (define/private (find-char-box text left-pos right-pos)
(send text position-location left-pos xlb ylb #t) (send text position-location left-pos xlb ylb #t)
(send text position-location right-pos xrb yrb #f) (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))] (define-values (xl-off yl-off)
[(xl yl) (dc-location-to-editor-location xl-off yl-off)] (send text editor-location-to-dc-location (unbox xlb) (unbox ylb)))
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))] (define-values (xl yl)
[(xr yr) (dc-location-to-editor-location xr-off yr-off)]) (dc-location-to-editor-location xl-off yl-off))
(values (define-values (xr-off yr-off)
xl (send text editor-location-to-dc-location (unbox xrb) (unbox yrb)))
yl (define-values (xr yr) (dc-location-to-editor-location xr-off yr-off))
xr (values
yr))) xl
yl
xr
yr))
(define/private (get-arrow-poss arrow) (define/private (get-arrow-poss arrow)
(cond (cond

1
pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
View File

@ -267,6 +267,7 @@ please adhere to these guidelines:
(online-expansion-error-margin "in the margin") (online-expansion-error-margin "in the margin")
; the label of a preference in the (string-constant online-expansion) section ; the label of a preference in the (string-constant online-expansion) section
(show-arrows-on-mouseover "Show binding and tail-position arrows on mouseover") (show-arrows-on-mouseover "Show binding and tail-position arrows on mouseover")
(show-blueboxes "Show blue boxes and blue box arrow semi-circle")
;;; info bar at botttom of drscheme frame ;;; info bar at botttom of drscheme frame
(collect-button-label "GC") (collect-button-label "GC")
(read-only "Read only") (read-only "Read only")