improve source location reporting in 2dmatch for empty cells

to make this happen, change the 2d reader so that it puts more
specific source location information into the read form

original commit: ffd4ea5b6cc284873ab04d53f6870e6e791d4964

pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt

@@ -27,6 +27,9 @@
                              (= 0 (list-ref lst 1))))
                 cells))
        
+       (define (cell-stx-object cell) 
+         (datum->syntax #f " " cell))
+       
        ;; build up the coord-to-content mapping for the 
        ;; boundary cells and build up the pattern-vars table
        (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
@@ -36,7 +39,8 @@
          (cond
            [(member (list 0 0) cells) 
             (unless (and rhses-lst (= 2 (length rhses-lst)))
-              (raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions"))
+              (raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions"
+                                  (cell-stx-object (car cells))))
             (with-syntax ([(left-x right-x) (generate-temporaries rhses)]
                           [(left-arg right-arg) rhses])
               (set! let-bindings (list* #`[right-x right-arg]
@@ -50,7 +54,8 @@
                                    "cell at ~a,~a must contain exactly one match pattern, found ~a"
                                    (list-ref (car cells) 0) (list-ref (car cells) 1)
                                    (length rhses-lst))
-                                  stx))
+                                  stx
+                                  (cell-stx-object (car (syntax-e cells-stx)))))
             (define pat (car (syntax->list rhses)))
             (hash-set! pattern-vars (car cells) (bound-vars (parse pat)))
             (hash-set! coord-to-content (car cells) pat)]))
@@ -68,7 +73,8 @@
                                  (format "cell at ~a,~a should not be empty"
                                          (list-ref (car cells) 0)
                                          (list-ref (car cells) 1))
-                                 stx))
+                                 stx
+                                 (cell-stx-object (car cells))))
            (define horizontal-vars (hash-ref pattern-vars (list (list-ref (car cells) 0) 0)))
            (define vertical-vars (hash-ref pattern-vars (list 0 (list-ref (car cells) 1))))
            

pkgs/gui-pkgs/gui-lib/unstable/2d/private/read-util.rkt

@@ -214,7 +214,8 @@ example uses:
       (pending-row '())
       (rows '())
       (current-row 0)
-      (cell-connections (make-hash)))))
+      (cell-connections (make-hash))
+      (position-of-first-cell (hash)))))
 
 (define-syntax (setup-state stx)
   (syntax-case stx ()
@@ -263,12 +264,13 @@ example uses:
        (values cell-connections 
                (apply vector (reverse rows))
                table-column-breaks
-               initial-space-count)])))
+               initial-space-count
+               position-of-first-cell)])))
 
 (struct guide (char srcloc) #:transparent)
 
   
-;; parse-2dcond returns three values:
+;; parse-2dcond returns four values:
 ;;  - a hash table encoding a graph that shows where the 
 ;;    broken walls are in the 2d
 ;;  - a vector of lists of strings containing the all of the line
@@ -390,7 +392,7 @@ example uses:
          (line-of-interest)
          (readerr "expected ╗ to terminate the first line" pos)])))
   
-  (define (process-a-line current-map)
+  (define (process-a-line current-map previous-line-separator?)
     (fetch-next-line)
     ;; check leading space
     (let loop ([n 0])
@@ -403,7 +405,7 @@ example uses:
          (line-of-interest)
          (readerr "expected leading space" n)]))
     (case (string-ref current-line initial-space-count)
-      [(#\║) (values (continue-line current-map) #t)]
+      [(#\║) (values (continue-line current-map previous-line-separator?) #t)]
       [(#\╠) (values (start-new-block current-map) #f)]
       [(#\╚) (values (finish-table current-map) #f)]
       [else 
@@ -512,12 +514,13 @@ example uses:
                previous-map
                current-column)])))
   
-  (define (continue-line map)
+  (define (continue-line map previous-line-separator?)
     (let loop ([current-cell-size (car table-column-breaks)]
                [table-column-breaks (cdr table-column-breaks)]
                [map map]
                [pos (+ initial-space-count 1)]
-               [column-number 0])
+               [column-number 0]
+               [starting-a-new-cell? #t])
       (cond
         [(zero? current-cell-size)
          (unless (< pos current-line-length)
@@ -540,7 +543,8 @@ example uses:
                   (cdr table-column-breaks)
                   (cdr map)
                   (+ pos 1)
-                  (+ column-number 1))])]
+                  (+ column-number 1)
+                  #t)])]
         [else
          (unless (< pos current-line-length)
            (line-of-interest)
@@ -548,11 +552,19 @@ example uses:
          (when (double-barred-char? (string-ref current-line pos))
            (line-of-interest)
            (readerr "expected not to find a cell boundary character" pos))
+         (when previous-line-separator?
+           (when starting-a-new-cell?
+             (set! position-of-first-cell
+                   (hash-set
+                    position-of-first-cell
+                    (list column-number current-row)
+                    (guide-srcloc (make-a-guide pos))))))
          (loop (- current-cell-size 1)
                table-column-breaks
                map
                (+ pos 1)
-               column-number)]))
+               column-number
+               #f)]))
     map)
   
   
@@ -640,10 +652,11 @@ example uses:
   (let loop ([map (or last-left-map
                       (begin
                         (process-first-line)
-                        (map (λ (x) #t) table-column-breaks)))])
+                        (map (λ (x) #t) table-column-breaks)))]
-    (define-values (next-map continue?) (process-a-line map))
+             [previous-line-separator? #t])
+    (define-values (next-map continue?) (process-a-line map previous-line-separator?))
     (cond
-      [continue? (loop next-map)]
+      [continue? (loop next-map #f)]
       [next-map next-map]
       [else #f])))
      

pkgs/gui-pkgs/gui-lib/unstable/2d/private/readtable.rkt

@@ -71,9 +71,15 @@ example uses:
             '()]
            [else (cons c (loop))])))
      (define-values (post-2d-line post-2d-col post-2d-span) (port-next-location port))
-     (define-values (cell-connections lines table-column-breaks initial-space-count)
+     (define-values (cell-connections 
+                     lines 
+                     table-column-breaks 
+                     initial-space-count 
+                     position-of-first-cell)
        (parse-2dcond port source _line _col _pos chars-read))
-     (define lhses (close-cell-graph cell-connections (length table-column-breaks) (vector-length lines)))
+     (define lhses (close-cell-graph cell-connections 
+                                     (length table-column-breaks)
+                                     (vector-length lines)))
      (define scratch-string (make-string (for/sum ([ss (in-vector lines)])
                                            (for/sum ([s (in-list ss)])
                                              (string-length s)))
@@ -89,6 +95,21 @@ example uses:
      (set-port-next-location! kwd-port _line (and _col (+ _col 1)) (and _pos (+ _pos 1)))
      (define kwd-stx (read-syntax source kwd-port))
      
+     (define line-width (+ initial-space-count 
+                           (apply + table-column-breaks)
+                           (max 0 (- (length table-column-breaks) 1))))
+     
+     (define (add-srclocs indicies)
+       (for/list ([index (in-list indicies)])
+         (define srcloc (hash-ref position-of-first-cell index))
+         (datum->syntax #f
+                        index
+                        (vector (srcloc-source srcloc)
+                                #f ;; line
+                                #f ;; col
+                                (srcloc-position srcloc)
+                                1))))
+     
      `(,kwd-stx
        
        ,table-column-breaks
@@ -104,7 +125,7 @@ example uses:
            (define scratch-port (open-input-string scratch-string))
            (when post-2d-line (port-count-lines! scratch-port))
            (set-port-next-location! scratch-port post-2d-line post-2d-col post-2d-span)
-           `[,(sort (set->list set-of-indicies) compare/xy)
+           `[,(add-srclocs (sort (set->list set-of-indicies) compare/xy))
              ,@(read-subparts source scratch-port 
                               initial-space-count table-column-breaks heights set-of-indicies
                               /recursive)]))]