add an option to disable the blue arrow things

(and thus the blue boxes) entirely

closes PR 13761

pkgs/drracket/drracket/private/syncheck/blueboxes-gui.rkt

@@ -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]
+             [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))
                           (list 0 shadow-start-color)
                           (list 1 shadow-end-color))])]))

pkgs/drracket/drracket/private/syncheck/gui.rkt

@@ -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-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%)
     ;; 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))]
+              (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))
+              (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

pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt

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