diff --git a/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt b/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt index e2bd199..cc35040 100644 --- a/pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt +++ b/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)))) diff --git a/pkgs/gui-pkgs/gui-lib/unstable/2d/private/read-util.rkt b/pkgs/gui-pkgs/gui-lib/unstable/2d/private/read-util.rkt index cfc9806..35f1ce5 100644 --- a/pkgs/gui-pkgs/gui-lib/unstable/2d/private/read-util.rkt +++ b/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)))]) - (define-values (next-map continue?) (process-a-line map)) + (map (λ (x) #t) table-column-breaks)))] + [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]))) diff --git a/pkgs/gui-pkgs/gui-lib/unstable/2d/private/readtable.rkt b/pkgs/gui-pkgs/gui-lib/unstable/2d/private/readtable.rkt index 7765517..254fc76 100644 --- a/pkgs/gui-pkgs/gui-lib/unstable/2d/private/readtable.rkt +++ b/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)]))]