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

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

@ -21,6 +21,7 @@
(define sc-read-more... (string-constant sc-read-more...))
(preferences:set-default 'drracket:syncheck:contracts-locked? #f boolean?)
(preferences:set-default 'drracket:syncheck:show-blueboxes? #t boolean?)
(define corner-radius 48)
(define blue-box-color (make-object color% #xE8 #xE8 #xFF))
@ -129,6 +130,7 @@
(inherit get-dc get-client-size get-editor
horizontal-inset vertical-inset)
(define/override (on-paint)
(when (preferences:get 'drracket:syncheck:show-blueboxes?)
(define e (get-editor))
(when e
(define dc (get-dc))
@ -188,7 +190,7 @@
(send dc set-font font)
(send dc set-smoothing smoothing)]
[the-strs
(draw-closed dc cw 0)]))
(draw-closed dc cw 0)])))
(super on-paint))
(super-new)))
@ -281,6 +283,12 @@
(define size (+ corner-radius shadow-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 by (box 0))
(define bw (box 0))
@ -303,6 +311,7 @@
(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)
(when (preferences:get 'drracket:syncheck:show-blueboxes?)
(define-values (br bt bmp-x bmp-y) (get-box-upper-right-and-lock-coordinates))
(when (and (not before?) br bt)
(define canvas (get-canvas))
@ -321,7 +330,7 @@
left top right bottom)]
[the-strs
(draw-closed dc (+ dx br) (+ dy bt))])))
(draw-closed dc (+ dx br) (+ dy bt))]))))
;; get-box-upper-right-and-lock-coordinates
;; : (or/c (-> (values #f #f #f #f)
@ -769,8 +778,12 @@
(new brush%
[gradient
(new radial-gradient%
[x0 (+ corner-radius shadow-size)] [y0 (+ corner-radius shadow-size)] [r0 corner-radius]
[x1 (+ corner-radius shadow-size)] [y1 (+ corner-radius shadow-size)] [r1 (+ shadow-size corner-radius)]
[x0 (+ corner-radius shadow-size)]
[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))
(list 0 shadow-start-color)
(list 1 shadow-end-color))])]))

33
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)
(preferences:add-check vp
'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)
(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)
(start-text start-pos-left start-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)
(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 templ-color 'solid)))
(define (get-tail-pen white-on-black?) (send the-pen-list find-or-create-pen "orchid" 1 '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))
(define (get-tail-pen white-on-black?)
(send the-pen-list find-or-create-pen "orchid" 1 '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%)
;; 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))
;; 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
(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)
(send text position-location left-pos xlb ylb #t)
(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))]
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
[(xr yr) (dc-location-to-editor-location xr-off yr-off)])
(define-values (xl-off yl-off)
(send text editor-location-to-dc-location (unbox xlb) (unbox ylb)))
(define-values (xl yl)
(dc-location-to-editor-location xl-off yl-off))
(define-values (xr-off yr-off)
(send text editor-location-to-dc-location (unbox xrb) (unbox yrb)))
(define-values (xr yr) (dc-location-to-editor-location xr-off yr-off))
(values
xl
yl
xr
yr)))
yr))
(define/private (get-arrow-poss arrow)
(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")
; 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-blueboxes "Show blue boxes and blue box arrow semi-circle")
;;; info bar at botttom of drscheme frame
(collect-button-label "GC")
(read-only "Read only")