suzanne.soy/racket
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
This commit is contained in:
Robby Findler 2013-08-20 12:58:35 -05:00
parent afb99f1e0d
commit ffd4ea5b6c
4 changed files with 110 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)]))]

52
pkgs/unstable-pkgs/unstable-doc/scribblings/2d.scrbl
View File

@ -85,6 +85,58 @@ well-formed @litchar{#2d} expression. In this case, the @racket[2dmatch]
treats any of the situations that fall into the larger regions as
the same.
In general, a @litchar{#2d} expression, when read, turns into an expression
with at least two sub-pieces (not counting the initial name). The first is
a sequence of numbers giving the widths of the top row of cells;
the second is also a sequence of numbers, this time giving the heights
of the leftmost column of cells. The remaining sequence describe the cells
content. The first element of each is itself a sequence of coordinates,
one for each of the cells that are connected together. The remaining elements
are the subexpressions in the given cells.
For example, this:
@codeblock{
#lang unstable/2d racket
'#2dex
╔══════════╦══════════╗
║ 0 ║ 1 ║
╠══════════╬══════════╣
║ 2 ║ 3 ║
╚══════════╩══════════╝
}
evaluates to
@racketblock['(2dex (10 10)
(2 2)
(((0 0)) 0)
(((0 1)) 2)
(((1 0)) 1)
(((1 1)) 3))]
and this
@codeblock{
#lang unstable/2d racket
'#2dex
╔══════════╦══════════╦══════════╗
║ 0 ║ 1 2 ║ 3 4 ║
╠══════════╬══════════╩══════════╣
║ 5 ║ 6 ║
╚══════════╩═════════════════════╝
}
evaluates to
@racketblock['(2dex (10 10 10)
(2 2)
(((0 0)) 0)
(((0 1)) 5)
(((1 0)) 1 2)
(((1 1) (2 1)) 6)
(((2 0)) 3 4))]
In addition, the cells coordinates pairs have source locations of the first
character that is inside the corresponding cell. (Currently the span
is always @racket[1], but that may change.)
@section{2D Cond}
@defmodule[unstable/2d/cond]