suzanne.soy/2d
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve source location reporting in 2dmatch for empty cells

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

original commit: ffd4ea5b6cc284873ab04d53f6870e6e791d4964
This commit is contained in:
Robby Findler 2013-08-20 12:58:35 -05:00
parent 81f2bbc394
commit 087af0fe05
3 changed files with 58 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/gui-pkgs/gui-lib/unstable/2d/match.rkt
View File

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

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

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

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

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