improve the way check syntax draws arrows

(a little bit thicker line and some alpha)

collects/drracket/arrow.rkt

@@ -48,20 +48,29 @@
 
 ; dc<%> real real real real real real -> void
 ; draw one arrow
-; The reason of the "-0.5" in the definition of start-x and end-x in the let
+(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy
-; right below is because, well, after numerous experiments done under carefully
+                    #:pen-width [pen-width #f])
-; controlled conditions by a team of independent experts, it was thought to
+  (define the-pen-width (or pen-width (send (send dc get-pen) get-width)))
-; be The Right Thing for the arrows to be drawn correctly, maybe.
+  (let ([uncropped-start-x (+ uncropped-pre-start-x dx (- (/ the-pen-width 2)))]
-(define (draw-arrow dc uncropped-pre-start-x uncropped-pre-start-y uncropped-pre-end-x uncropped-pre-end-y dx dy)
-  (let ([uncropped-start-x (+ uncropped-pre-start-x dx -0.5)]
         [uncropped-start-y (+ uncropped-pre-start-y dy)]
-        [uncropped-end-x (+ uncropped-pre-end-x dx -0.5)]
+        [uncropped-end-x (+ uncropped-pre-end-x dx (- (/ the-pen-width 2)))]
         [uncropped-end-y (+ uncropped-pre-end-y dy)]
         [old-smoothed (send dc get-smoothing)])
     (let*-values ([(start-x start-y) (crop-to uncropped-start-x uncropped-start-y uncropped-end-x uncropped-end-y)]
                   [(end-x end-y) (crop-to uncropped-end-x uncropped-end-y uncropped-start-x uncropped-start-y)])
       (send dc set-smoothing 'aligned)
+      (define saved-pen (send dc get-pen))
+      (when pen-width
+        (send dc set-pen
+              (let ([p (send dc get-pen)])
+                (send the-pen-list find-or-create-pen 
+                      (send p get-color)
+                      pen-width
+                      (send p get-style)
+                      (send p get-cap)
+                      (send p get-join)))))
       (send dc draw-line start-x start-y end-x end-y)
+      (send dc set-pen saved-pen)
       (when (and (< smallest start-x largest)
                  (< smallest start-y largest))
         (send dc draw-ellipse 

collects/drracket/private/syncheck/gui.rkt

@@ -190,12 +190,13 @@ If the namespace does not, they are colored the unbound color.
     
     (define-struct graphic (pos* locs->thunks draw-fn click-fn))
     
-    (define-struct arrow (start-x start-y end-x end-y) #:mutable)
+    (define-struct arrow (start-x start-y end-x end-y) #:mutable #:transparent)
     (define-struct (var-arrow arrow)
       (start-text start-pos-left start-pos-right
                   end-text end-pos-left end-pos-right
-                  actual? level)) ;; level is one of 'lexical, 'top-level, 'import
+                  actual? level) ;; level is one of 'lexical, 'top-level, 'import
-    (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)
     
     ;; color : string
     ;; text: text:basic<%>
@@ -777,7 +778,8 @@ If the namespace does not, they are colored the unbound color.
                                [end-y   (arrow-end-y arrow)])
                            (unless (and (= start-x end-x)
                                         (= start-y end-y))
-                             (drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy)
+                             (drracket:arrow:draw-arrow dc start-x start-y end-x end-y dx dy
+                                                        #:pen-width 2)
                              (when (and (var-arrow? arrow) (not (var-arrow-actual? arrow)))
                                (let-values ([(fw fh _d _v) (send dc get-text-extent "x")])
                                  (send dc draw-text "?"
@@ -787,7 +789,8 @@ If the namespace does not, they are colored the unbound color.
                       [old-pen   (send dc get-pen)]
                       [old-font  (send dc get-font)]
                       [old-text-foreground (send dc get-text-foreground)]
-                      [old-text-mode (send dc get-text-mode)])
+                      [old-text-mode (send dc get-text-mode)]
+                      [old-alpha (send dc get-alpha)])
                   (send dc set-font
                         (send the-font-list find-or-create-font
                               (send old-font get-point-size)
@@ -795,6 +798,7 @@ If the namespace does not, they are colored the unbound color.
                               'normal
                               'bold))
                   (send dc set-text-foreground templ-color)
+                  (send dc set-alpha 0.5)
                   (hash-for-each tacked-hash-table
                                  (λ (arrow v) 
                                     (when v 
@@ -811,7 +815,8 @@ If the namespace does not, they are colored the unbound color.
                                       (draw-arrow2 arrow))))
                   (when (and cursor-location
                              cursor-text)
-                    (let* ([arrow-record (hash-ref arrow-records cursor-text #f)])
+                    (define arrow-record (hash-ref arrow-records cursor-text #f))
+                    (define tail-arrows '())
                     (when arrow-record
                       (for ([ele (in-list (interval-map-ref arrow-record cursor-location null))])
                         (cond [(var-arrow? ele)
@@ -822,33 +827,37 @@ If the namespace does not, they are colored the unbound color.
                                           (send dc set-brush untacked-brush)))
                                (draw-arrow2 ele)]
                               [(tail-arrow? ele)
+                               (set! tail-arrows (cons ele tail-arrows))])))
+                    
                     (send dc set-pen tail-pen)
                     (send dc set-brush untacked-brush)
-                                 (for-each-tail-arrows draw-arrow2 ele)])))))
+                    (for-each-tail-arrows draw-arrow2 tail-arrows))
                   (send dc set-brush old-brush)
                   (send dc set-pen old-pen)
                   (send dc set-font old-font)
                   (send dc set-text-foreground old-text-foreground)
-                  (send dc set-text-mode old-text-mode)))
+                  (send dc set-text-mode old-text-mode)
+                  (send dc set-alpha old-alpha)))
               
               ;; do the drawing before calling super so that the arrows don't
               ;; cross the "#lang ..." line, if it is present.
               (super on-paint before dc left top right bottom dx dy draw-caret))
             
             ;; for-each-tail-arrows : (tail-arrow -> void) tail-arrow -> void
-            (define/private (for-each-tail-arrows f tail-arrow)
+            (define/private (for-each-tail-arrows f tail-arrows)
               ;; call-f-ht ensures that `f' is only called once per arrow
-              (define call-f-ht (make-hasheq))
+              (define call-f-ht (make-hash))
               
+              (for ([tail-arrow (in-list tail-arrows)])
                 (define (for-each-tail-arrows/to/from tail-arrow-pos tail-arrow-text
                                                       tail-arrow-other-pos tail-arrow-other-text)
                   
                   ;; traversal-ht ensures that we don't loop in the arrow traversal.
                   (let ([traversal-ht (make-hasheq)])
                     (let loop ([tail-arrow tail-arrow])
-                    (unless (hash-ref traversal-ht tail-arrow (λ () #f))
+                      (unless (hash-ref traversal-ht tail-arrow #f)
                         (hash-set! traversal-ht tail-arrow #t)
-                      (unless (hash-ref call-f-ht tail-arrow (λ () #f))
+                        (unless (hash-ref call-f-ht tail-arrow #f)
                           (hash-set! call-f-ht tail-arrow #t)
                           (f tail-arrow))
                         (let* ([next-pos (tail-arrow-pos tail-arrow)]
@@ -863,11 +872,10 @@ If the namespace does not, they are colored the unbound color.
                                    (when (and (= other-pos next-pos)
                                               (eq? other-text next-text))
                                      (loop ele)))]))))))))
-              
                 (for-each-tail-arrows/to/from tail-arrow-to-pos tail-arrow-to-text
                                               tail-arrow-from-pos tail-arrow-from-text)
                 (for-each-tail-arrows/to/from tail-arrow-from-pos tail-arrow-from-text
-                                            tail-arrow-to-pos tail-arrow-to-text))
+                                              tail-arrow-to-pos tail-arrow-to-text)))
             
             (define last-known-mouse-x #f)
             (define last-known-mouse-y #f)
@@ -1079,7 +1087,7 @@ If the namespace does not, they are colored the unbound color.
                      [(tail-arrow? arrow)
                       (for-each-tail-arrows
                        (λ (arrow) (set! untack-arrows? (or untack-arrows? (arrow-tacked? arrow))))
-                       arrow)]))
+                       (list arrow))]))
                  arrows)
                 (for-each 
                  (λ (arrow)
@@ -1090,7 +1098,7 @@ If the namespace does not, they are colored the unbound color.
                       (for-each-tail-arrows
                        (λ (arrow) 
                          (hash-set! tacked-hash-table arrow (not untack-arrows?)))
-                       arrow)]))
+                       (list arrow))]))
                  arrows))
               (invalidate-bitmap-cache))