IN PROGRESS: working on rect support for error messages for 2d cond

pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt

@@ -28,6 +28,7 @@ profile todo:
          mrlib/include-bitmap
          images/compile-time
          pkg/lib
+         syntax/rect
          (for-syntax images/icons/misc images/icons/style images/icons/control images/logos)
          (for-syntax racket/base)
          (submod "frame.rkt" install-pkg))
@@ -338,9 +339,13 @@ profile todo:
                        [(pair? stack2)
                         (list (car stack2))]
                        [else '()])]
+           [srcloc-rects (cond
+                           [(and (exn:srcloc-rects? exn)
+                                 (exn:srclocs? exn)) ;; only look at the rects when the exn has srclocs
+                            ((exn:srcloc-rects-accessor exn) exn)]
+                           [else #f])]
            [src-locs-edition (and (pair? src-locs)
                                   (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
-
       (print-planet-icon-to-stderr exn)
       (unless (exn:fail:user? exn)
         (unless (exn:fail:syntax? exn)
@@ -362,9 +367,12 @@ profile todo:
            (λ ()
              ;; need to make sure that the user's eventspace is still the same
              ;; and still running here?
-             (send ints highlight-errors src-locs (if (null? stack1)
+             (send ints highlight-errors 
+                   src-locs 
+                   (if (null? stack1)
                        stack2
-                                                      stack1))))))))
+                       stack1)
+                   srcloc-rects)))))))
   
   (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
     (let ([src (srcloc-source srcloc)])

pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt

@@ -187,6 +187,7 @@
       (list ''#%foreign
             '(lib "mzlib/pconvert-prop.rkt")
             '(lib "planet/terse-info.rkt")
+            '(lib "syntax/rect.rkt")
             ;; preserve the invariant that:
             ;;   if a module is shared, so 
             ;;   are all of its submodules

pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt

@@ -23,6 +23,7 @@ TODO
          racket/port
          racket/set
          
+         syntax/rect
          string-constants
          setup/xref
          racket/gui/base
@@ -550,10 +551,66 @@ TODO
       ;; error-ranges : (union false? (cons srcloc (listof srcloc)))
       (define error-ranges #f)
       (define/public (get-error-ranges) error-ranges)
-      (define/public (set-error-ranges ranges)
+      (define/public (set-error-ranges srclocs [srcloc-rects #f])
-        (set! error-ranges (and ranges 
+        (define candidate-srclocs
-                                (not (null? ranges))
+          (and srclocs
-                                (cleanup-locs ranges))))
+               (not (null? srclocs))
+               (cleanup-locs srclocs)))
+        (cond
+          [(and candidate-srclocs srcloc-rects)
+           (set! error-ranges
+                 (apply
+                  append
+                  (for/list ([srcloc (in-list candidate-srclocs)])
+                    (define pending-range-start #f)
+                    (define pending-range-end #f)
+                    (define srclocs '())
+                    (for ([pos (in-range (srcloc-position srcloc)
+                                         (+ (srcloc-position srcloc) 
+                                            (srcloc-span srcloc)))])
+                      (define keep-pos?
+                        (for/or ([srcloc-rect (in-list srcloc-rects)]
+                                 #:when (equal? (srcloc-rect-source srcloc-rect)
+                                                (srcloc-source range)))
+                          (pos-in-rect? pos srcloc-rect)))
+                      
+                      (when keep-pos?
+                        (cond
+                          [(not pending-range-start)
+                           (set! pending-range-start pos)
+                           (set! pending-range-end pos)]
+                          [(= (+ pending-range-end 1) pos)
+                           (set! pending-range-end pos)]
+                          [else
+                           (set! srclocs (cons (srcloc (srcloc-source srcloc)
+                                                       #f #f
+                                                       pending-range-start
+                                                       (- pending-range-end pending-range-start))
+                                               srclocs))
+                           (set! pending-range-start pos)
+                           (set! pending-range-end pos)])))
+                    srclocs)))]
+          [else
+           (set! error-ranges candidate-srclocs)]))
+      
+      (define/private (pos-in-rect? pos srcloc-rect)
+        (define src (srcloc-rect-source srcloc-rect))
+        (define height (srcloc-rect-height srcloc-rect))
+        (define width (srcloc-rect-width srcloc-rect))
+        (cond
+          [(is-a? src text%)
+           (define start-para (send src position-paragraph (srcloc-rect-pos srcloc-rect)))
+           (define para-offset (- (srcloc-rect-pos srcloc-rect) start-para))
+           (let loop ([this-line-start (srcloc-rect-pos srcloc-rect)]
+                      [y 0])
+             (cond
+               [(= y height) #f]
+               [(<= this-line-start pos (+ this-line-start width)) #t]
+               [else 
+                (loop (+ (send src paragraph-start-position (+ start-para y)) para-offset)
+                      (+ y 1))]))]
+          [else #f]))
+      
       (define clear-error-highlighting void)
       (define/public (reset-error-ranges) 
         (set-error-ranges #f)
@@ -577,11 +634,12 @@ TODO
       ;; =Kernel= =handler=
       ;; highlight-errors :    (listof srcloc)
       ;;                       (union #f (listof srcloc))
+      ;;                       (union #f (listof srcloc-rect))
       ;;                    -> (void)
-      (define/public (highlight-errors raw-locs [raw-error-arrows #f])
+      (define/public (highlight-errors raw-locs [raw-error-arrows #f] [srcloc-rects #f])
         (clear-error-highlighting)
         (when definitions-text (send definitions-text set-error-arrows #f))
-        (set-error-ranges raw-locs)
+        (set-error-ranges raw-locs srcloc-rects)
         (define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs
         (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))
         

racket/collects/syntax/rect.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+(provide (struct-out exn:fail:syntax/rects)
+         (struct-out exn:fail:read/rects)
+         (struct-out exn:fail:read:eof/rects)
+         (struct-out exn:fail:read:non-char/rects)
+         (struct-out srcloc-rect)
+         prop:exn:srcloc-rects 
+         exn:srcloc-rects? 
+         exn:srcloc-rects-accessor)
+
+(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor)
+  (make-struct-type-property 'exn:srcloc-rects))
+
+(struct exn:fail:syntax/rects exn:fail:syntax (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x)))
+
+(struct exn:fail:read/rects exn:fail:read (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x)))
+(struct exn:fail:read:eof/rects exn:fail:read:eof (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x)))
+(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x)))
+
+(struct srcloc-rect (source pos width height) #:transparent)

racket/lib/collects/syntax/rect.rkt

@@ -0,0 +1,24 @@
+#lang racket/base
+(provide (struct-out exn:fail:syntax/rects)
+         (struct-out exn:fail:read/rects)
+         (struct-out exn:fail:read:eof/rects)
+         (struct-out exn:fail:read:non-char/rects)
+         (struct-out srcloc-rect)
+         prop:exn:srcloc-rects 
+         exn:srcloc-rects? 
+         exn:srcloc-rects-accessor)
+
+(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor)
+  (make-struct-type-property 'exn:srcloc-rects))
+
+(struct exn:fail:syntax/rects exn:fail:syntax (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x)))
+
+(struct exn:fail:read/rects exn:fail:read (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x)))
+(struct exn:fail:read:eof/rects exn:fail:read:eof (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x)))
+(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects)
+  #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x)))
+
+(struct srcloc-rect (source pos width height) #:transparent)