diff --git a/collects/unstable/2d/reader.rkt b/collects/unstable/2d/reader.rkt index c56b6798a3..99ee3675be 100644 --- a/collects/unstable/2d/reader.rkt +++ b/collects/unstable/2d/reader.rkt @@ -7,22 +7,32 @@ (for-syntax racket/base racket/list)) + +(define all-line-of-interest (make-hash)) +(define current-lines (make-parameter #f)) +(define-syntax (line-of-interest stx) + (with-syntax ([line (syntax-line stx)]) + (syntax-local-lift-expression #'(hash-set! all-line-of-interest line #t)) + #'(visited line))) +(define (visited line) + (define t (current-lines)) + (when t + (hash-remove! t line))) + (define rt (make-readtable #f #\2 'dispatch-macro (λ (char port source _line _col _pos) - (define pport (peeking-input-port port)) - (define dcond-count 5) - (define dcond (for/list ([i (in-range dcond-count)]) (read-char pport))) + (define next-char (peek-char port)) (cond - [(equal? dcond '(#\d #\c #\o #\n #\d)) - (define chars-read 0) + [(equal? next-char #\d) + (define chars-read 2) ;; account for the # and the 2 (define (rc) (set! chars-read (+ chars-read 1)) (read-char port)) - (for ([i (in-range dcond-count)]) (rc)) + (rc) ;; get the #\d (define nl (rc)) (cond [(equal? nl #\newline) (void)] @@ -30,10 +40,11 @@ (when (equal? #\newline (peek-char port)) (rc))] [else - (raise-read-error "expected a newline to follow #2dcond" + (line-of-interest) + (raise-read-error "expected a newline to follow #2d" (object-name port) _line _col _pos - 6)]) + 2)]) (parse-2dcond port source _line _col _pos chars-read)] [else (read/recursive @@ -45,9 +56,11 @@ (define current-line-number _line) (define current-line-start-position (+ _pos chars-read)) (define current-line "") - (define table-column-breaks '()) (define initial-space-count 0) + (define initial-column-guide #f) (define newline-char-count 0) + (define table-column-breaks '()) + (define table-column-guides '()) (define current-row 0) (define cell-connections (make-hash)) @@ -96,70 +109,93 @@ (define (process-first-line) (fetch-next-line) - (cond - [(eq? current-line 'terminator) - (readerr "expected to find a table" port)] - [else - (let loop ([pos 0]) + (let loop ([pos 0]) + (cond + [(< pos (string-length current-line)) (cond - [(< pos (string-length current-line)) - (cond - [(equal? #\space (string-ref current-line pos)) - (loop (+ pos 1))] - [(equal? #\╔ (string-ref current-line pos)) - (set! initial-space-count pos)] - [else - (readerr "expected the first character in the table to be ╔" - pos 1)])] + [(equal? #\space (string-ref current-line pos)) + (loop (+ pos 1))] + [(equal? #\╔ (string-ref current-line pos)) + (set! initial-column-guide (make-a-guide pos)) + (set! initial-space-count pos)] [else - (readerr "expected some non-whitespace characters in the first line of the table" - 0 - pos)])) - (set! table-column-breaks - (let loop ([pos (+ initial-space-count 1)] - [current-column-width 0] - [column 0]) - (cond - [(< pos (string-length current-line)) - (case (string-ref current-line pos) - [(#\╦) - (add-node column 0) - (cons current-column-width (loop (+ pos 1) 0 (+ column 1)))] - [(#\═) (loop (+ pos 1) (+ current-column-width 1) column)] - [(#\╗) - (add-node column 0) - (let loop ([pos (+ pos 1)]) - (when (< pos (string-length current-line)) - (cond - [(char-whitespace? (string-ref current-line pos)) - (loop (+ pos 1))] - [else - (readerr "expected only whitespace to follow ╗ (on the same line)" pos)])) - (list current-column-width))])] - [else - (readerr "expected ╗ to terminate the first line" pos)])))])) + (line-of-interest) + (readerr "expected the first character in the table to be ╔" + pos)])] + [else + (line-of-interest) + (readerr "expected some non-whitespace characters in the first line of the table" + 0 + pos)])) + (let loop ([pos (+ initial-space-count 1)] + [current-column-width 0] + [column 0]) + (cond + [(< pos (string-length current-line)) + (case (string-ref current-line pos) + [(#\╦) + (add-node column 0) + (cons current-column-width (loop (+ pos 1) 0 (+ column 1)))] + [(#\═) (loop (+ pos 1) (+ current-column-width 1) column)] + [(#\╗) + (add-node column 0) + (let loop ([pos (+ pos 1)]) + (when (< pos (string-length current-line)) + (cond + [(char-whitespace? (string-ref current-line pos)) + (loop (+ pos 1))] + [else + (line-of-interest) + (readerr "expected only whitespace to follow ╗ (on the same line)" pos)])) + (list current-column-width))])] + [else + (line-of-interest) + (readerr "expected ╗ to terminate the first line" pos)])) + (let loop ([pos (+ initial-space-count 1)] + [current-column-width 0] + [column 0] + [column-breaks '()] + [column-guides '()]) + (cond + [(< pos (string-length current-line)) + (case (string-ref current-line pos) + [(#\╦) + (add-node column 0) + (loop (+ pos 1) 0 (+ column 1) + (cons current-column-width column-breaks) + (cons (make-a-guide pos) column-guides))] + [(#\═) (loop (+ pos 1) (+ current-column-width 1) column + column-breaks column-guides)] + [(#\╗) + (add-node column 0) + (whitespace-to-end (+ pos 1)) + (set! table-column-breaks (reverse (cons current-column-width column-breaks))) + (set! table-column-guides (reverse (cons (make-a-guide pos) column-guides)))])] + [else + (line-of-interest) + (readerr "expected ╗ to terminate the first line" pos)]))) (define (process-a-line current-map) (fetch-next-line) - (cond - [(eq? current-line 'terminator) - (readerr "incomplete table" port)] - [else - ;; check leading space - (let loop ([n 0]) - (cond - [(= n initial-space-count) (void)] - [(and (< n (string-length current-line)) - (equal? #\space (string-ref current-line n))) - (loop (+ n 1))] - [else - (readerr "expected leading space" n)])) - (case (string-ref current-line initial-space-count) - [(#\║) (continue-line current-map)] - [(#\╠) (start-new-block current-map)] - [(#\╚) (finish-table current-map)] - [else (readerr/expected '(#\║ #\╠ #\╚) - initial-space-count)])])) + ;; check leading space + (let loop ([n 0]) + (cond + [(= n initial-space-count) (void)] + [(and (< n (string-length current-line)) + (equal? #\space (string-ref current-line n))) + (loop (+ n 1))] + [else + (line-of-interest) + (readerr "expected leading space" n)])) + (case (string-ref current-line initial-space-count) + [(#\║) (continue-line current-map)] + [(#\╠) (start-new-block current-map)] + [(#\╚) (finish-table current-map)] + [else + (line-of-interest) + (readerr/expected '(#\║ #\╠ #\╚) + initial-space-count + #:guides (list initial-column-guide))])) (define (start-new-block previous-map) (set! current-row (+ current-row 1)) @@ -172,6 +208,10 @@ ;; we're currently traversing is there (or not) [cell-wall-broken? #f] + ;; the srcloc of the spot that led us to the decision + ;; of which boolean that cell-wall-broken? should be + [cell-wall-guide (make-a-guide initial-space-count)] + ;; this is the result, being built up backwards [map '()] @@ -183,12 +223,15 @@ (cond [(zero? current-cell-size) (unless (< pos (string-length current-line)) - (readerr "line ended too soon")) + (line-of-interest) + (readerr "line ended too soon" pos)) (define sep (string-ref current-line pos)) (cond [(and cell-wall-broken? (not (car previous-map))) - (when (table-char? (string-ref current-line pos)) - (readerr "expected not to find a cell boundary character" pos))] + (unless (equal? sep #\╔) + (when (table-char? sep) + (line-of-interest) + (readerr "expected not to find a cell boundary character" pos)))] [else (define allowed-chars (if (null? table-column-breaks) @@ -200,6 +243,7 @@ (get-one (not cell-wall-broken?) (car previous-map) #t #t)))) (set! allowed-chars (filter values allowed-chars)) (unless (member sep allowed-chars) + (line-of-interest) (readerr/expected allowed-chars pos))]) (cond [(null? table-column-breaks) @@ -220,23 +264,32 @@ (cdr table-column-breaks) (+ pos 1) next-cell-wall-broken? + (make-a-guide pos) (cons edge-going-down? map) (cdr previous-map) next-column)])] [else (unless (< pos (string-length current-line)) + (line-of-interest) (readerr "line ended in the middle of a cell" pos)) (cond [cell-wall-broken? (when (table-char? (string-ref current-line pos)) - (readerr "expected not to find a cell boundary character" pos))] + (line-of-interest) + (readerr + (format "expected not to find a cell boundary character (based on earlier ~a)" + (guide-char cell-wall-guide)) + pos + #:guides (list cell-wall-guide)))] [else (unless (equal? (string-ref current-line pos) #\═) + (line-of-interest) (readerr/expected '(#\═) pos))]) (loop (- current-cell-size 1) table-column-breaks (+ pos 1) cell-wall-broken? + cell-wall-guide map previous-map current-column)]))) @@ -250,13 +303,16 @@ (cond [(zero? current-cell-size) (unless (< pos (string-length current-line)) + (line-of-interest) (readerr "line ended at the boundary of a cell, expected the edge of the cell" pos)) (cond [(car map) (unless (equal? (string-ref current-line pos) #\║) + (line-of-interest) (readerr/expected '(#\║) pos))] [else (when (table-char? (string-ref current-line pos)) + (line-of-interest) (readerr "expected not to find a cell boundary character" pos))]) (cond [(null? table-column-breaks) @@ -269,8 +325,10 @@ (+ column-number 1))])] [else (unless (< pos (string-length current-line)) + (line-of-interest) (readerr "line ended in the middle of a cell" pos)) (when (table-char? (string-ref current-line pos)) + (line-of-interest) (readerr "expected not to find a cell boundary character" pos)) (loop (- current-cell-size 1) table-column-breaks @@ -288,6 +346,7 @@ (cond [(zero? current-cell-size) (unless (< pos (string-length current-line)) + (line-of-interest) (readerr "line ended in the middle of a cell" pos)) (define expected-char (cond @@ -295,6 +354,7 @@ [(car map) #\╩] [else #\═])) (unless (equal? (string-ref current-line pos) expected-char) + (line-of-interest) (readerr/expected (list expected-char) pos)) (cond [(null? table-column-breaks) @@ -306,8 +366,10 @@ (+ pos 1))])] [else (unless (< pos (string-length current-line)) + (line-of-interest) (readerr "line ended in the middle of a cell" pos)) (unless (equal? (string-ref current-line pos) #\═) + (line-of-interest) (readerr/expected '(#\═) pos)) (loop (- current-cell-size 1) table-column-breaks @@ -318,19 +380,41 @@ (let loop ([pos pos]) (when (< pos (string-length current-line)) (unless (equal? #\space (string-ref current-line pos)) + (line-of-interest) (readerr "expected only whitespace outside of the table" pos)) (loop (+ pos 1))))) - (define (readerr/expected chars pos-in-line) - (readerr (format "expected ~a" (chars->desc chars)) - pos-in-line)) - (define (readerr msg pos-in-line [span 1]) - (raise-read-error msg (object-name port) + (struct guide (char srcloc)) + + (define (make-a-guide pos-in-line) + (guide (string-ref current-line pos-in-line) + (srcloc source current-line-number pos-in-line + (+ current-line-start-position pos-in-line) + 1))) + + (define (readerr/expected chars pos-in-line #:guides [guides '()]) + (readerr (format "expected ~a~a~a" + (if (null? (cdr chars)) + "" + "one of ") + (chars->desc chars "or") + (if (null? guides) + "" + (format " (based on earlier ~a)" + (chars->desc (map guide-char guides) + "and")))) + pos-in-line + #:guides guides)) + + (define (readerr msg pos-in-line [span 1] #:guides [guides '()]) + (raise-read-error msg + source current-line-number pos-in-line (+ current-line-start-position pos-in-line) - span)) + span + #:extra-srclocs (map guide-srcloc guides))) (process-first-line) (let loop ([map (map (λ (x) #t) table-column-breaks)]) @@ -343,7 +427,7 @@ ;; chars : non-empty-list-of-char -> string -(define (chars->desc chars) +(define (chars->desc chars sep) (cond [(null? (cdr chars)) (format "~a" (car chars))] @@ -351,16 +435,20 @@ (define commas? (pair? (cddr chars))) (apply string-append - "one of" - (let loop ([chars chars]) + (let loop ([chars chars] + [first? #t]) (cond [(null? (cdr chars)) - (list (format " or ~a" (car chars)))] + (list (format "~a~a ~a" + (if first? "" " ") + sep + (car chars)))] [else - (cons (format " ~a~a" + (cons (format "~a~a~a" + (if first? "" " ") (car chars) (if commas? "," "")) - (loop (cdr chars)))])))])) + (loop (cdr chars) #f))])))])) (define table-chars '(#\═ #\║ #\╔ #\╦ #\╗ #\╠ #\╬ #\╣ #\╚ #\╩ #\╝)) (define (table-char? c) (member c table-chars)) @@ -377,16 +465,18 @@ (module+ test (require rackunit) - (check-equal? (chars->desc '(#\a)) + (define touched-lines-table (make-hash)) + + (check-equal? (chars->desc '(#\a) "or") "a") - (check-equal? (chars->desc '(#\a #\b)) - "one of a or b") - (check-equal? (chars->desc '(#\a #\b #\c)) - "one of a, b, or c") - (check-equal? (chars->desc '(#\a #\b #\c #\d)) - "one of a, b, c, or d") - (check-equal? (chars->desc '(#\a #\b #\c #\d #\e)) - "one of a, b, c, d, or e") + (check-equal? (chars->desc '(#\a #\b) "or") + "a or b") + (check-equal? (chars->desc '(#\a #\b #\c) "or") + "a, b, or c") + (check-equal? (chars->desc '(#\a #\b #\c #\d) "or") + "a, b, c, or d") + (check-equal? (chars->desc '(#\a #\b #\c #\d #\e) "or") + "a, b, c, d, or e") (check-equal? (read (open-input-string "#2(x)")) (parameterize ([current-readtable rt]) @@ -399,41 +489,44 @@ (check-regexp-match #rx"expected a newline" (with-handlers ((exn:fail? exn-message)) (parameterize ([current-readtable rt]) - (read (open-input-string "#2dcond"))))) + (read (open-input-string "#2d"))))) - (define (get-err-positions inputs) - (with-handlers ((exn:fail:read? + (define (get-err-locs inputs) + (with-handlers ([exn:fail:read? (λ (exn) - (map srcloc-position (exn:fail:read-srclocs exn))))) + (for/list ([s (exn:fail:read-srclocs exn)]) + (struct-copy srcloc s [source #f])))]) + (define p (open-input-string (apply string-append inputs))) + (port-count-lines! p) (parameterize ([current-readtable rt]) - (read (open-input-string (apply string-append inputs)))) + (read p)) #f)) (define (get-graph inputs) (define p (open-input-string (apply string-append inputs))) (port-count-lines! p) - ;; account for the "#2dcond" that was read from the first line - (parse-2dcond p "source" 1 0 1 6)) + ;; account for the "#2d" that was read from the first line + (parse-2dcond p "source" 1 0 1 2)) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" "╔══╦══╗\n" "║1 ║2 ║\n" "╠══╬══╣\n" "║4 ║3 ║\n" "╚══╩══╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╗\n" " ║1 ║4 ║\n" " ╠══╬══╣\n" " ║2 ║3 ║\n" " ╚══╩══╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╦══╗\n" " ║1 ║2 ║3 ║\n" " ╠══╬══╬══╣\n" @@ -442,8 +535,8 @@ " ║7 ║8 ║9 ║\n" " ╚══╩══╩══╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╦══╗\n" " ║ 1║ 2║ 3║\n" " ╠══╬══╩══╣\n" @@ -452,8 +545,8 @@ " ║ 5║ ║\n" " ╚══╩═════╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╦══╗\n" " ║ 1║ 2║ 3║\n" " ╠══╬══╩══╣\n" @@ -462,16 +555,16 @@ " ║ 6║7 ║\n" " ╚══╩═════╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╦══╦══╗\n" " ║ 1║ 2║ 3║ 4║\n" " ╠══╬══╬══╩══╣\n" " ║ 4║ 5║ 6 ║\n" " ╚══╩══╩═════╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" + (check-equal? (get-err-locs + '("#2d\n" " ╔══╦══╦══╗\n" " ║1 ║2 ║3 ║\n" " ╠══╬══╬══╣\n" @@ -480,30 +573,31 @@ " ║5 ║6 ║7 ║\n" " ╚══╩══╩══╝\n")) #f) - (check-equal? (get-err-positions - '("#2dcond\n" - " ╔══╦══╗\n" - " ║ ║ ║\n" - " ╠══╣ ║\n" - " ║ ║ ║\n" - " ╚══╩══╝\n")) - '(something)) ;; that first ═ line has to go all the way across - (check-equal? (get-err-positions - '("#2dcond\n" - " ╔══╦══╗\n" - " ║ ║\n" - " ╠══╬══╣\n" - " ║ ║ ║\n" - " ╚══╩══╝\n")) - '(12 2)) - (check-equal? (get-err-positions - '("#2dcond\n" - " ╔══╦══╗\n" - " ║ ═║ ║\n" - " ╠══╬══╣\n" - " ║ ║ ║\n" - " ╚══╩══╝\n")) - '(14 4)) + + (define lines-table (hash-copy all-line-of-interest)) + (parameterize ([current-lines lines-table]) + (check-equal? (get-err-locs + '("#2d\n" + " ╔══╦══╗\n" + " ║ ║\n" + " ╠══╬══╣\n" + " ║ ║ ║\n" + " ╚══╩══╝\n")) + (list (srcloc #f 3 2 17 1) + (srcloc #f 2 2 7 1))) + (check-equal? (get-err-locs + '("#2d\n" + " ╔══╦══╗\n" + " ║ ═║ ║\n" + " ╠══╬══╣\n" + " ║ ║ ║\n" + " ╚══╩══╝\n")) + (list (srcloc #f 3 4 19 1) + (srcloc #f 2 4 9 1)))) + (let ([lines (hash-map lines-table (λ (x y) x))]) + (unless (null? lines) + (eprintf "no test case for errors on lines: ~s\n" + (sort lines <)))) (check-equal? (get-graph @@ -543,34 +637,85 @@ (cons (list 1 2) (set)) (cons (list 2 0) (set)) (cons (list 2 1) (set)) - (cons (list 2 2) (set)))))) + (cons (list 2 2) (set))))) + + (check-equal? (get-graph + '(" ╔══╦══╦══╦══╗\n" + " ║1 ║2 ║3 ║4 ║\n" + " ╠══╬══╩══╩══╣\n" + " ║6 ║5 ║\n" + " ╠══╣ ╔══╗ ║\n" + " ║7 ║ ║10║ ║\n" + " ╠══╣ ╚══╝ ║\n" + " ║7 ║ ║\n" + " ╚══╩════════╝\n")) + (make-hash + (list (cons (list 0 0) (set)) + (cons (list 0 1) (set)) + (cons (list 0 2) (set)) + (cons (list 0 3) (set)) + + (cons (list 1 0) (set)) + (cons (list 1 1) (set (list 1 2) (list 2 1))) + (cons (list 1 2) (set (list 1 1) (list 1 3))) + (cons (list 1 3) (set (list 1 2) (list 2 3))) + + (cons (list 2 0) (set)) + (cons (list 2 1) (set (list 1 1) (list 3 1))) + (cons (list 2 2) (set)) + (cons (list 2 3) (set (list 1 3) (list 3 3))) + + (cons (list 3 0) (set)) + (cons (list 3 1) (set (list 2 1) (list 3 2))) + (cons (list 3 2) (set (list 3 1) (list 3 3))) + (cons (list 3 3) (set (list 3 2) (list 2 3)))))) + + + #| +;; need to figure out what to do +;; with these examples + (check-equal? (get-err-positions + '("#2d\n" + " ╔══╦══╗\n" + " ║ ║ ║\n" + " ╠══╣ ║\n" + " ║ ║ ║\n" + " ╚══╩══╝\n")) + '(something)) ;; that first ═ line has to go all the way across + + (check-equal? (get-err-positions + '("#2d\n" + " ╔══╦══╗\n" + " ║ ║ ║\n" + " ╠══╩══╣\n" + " ║ ║\n" + " ╚═════╝\n")) + '(something)) ;; that first ║ line has to go all the way down + |# + + ) #; (module+ main - (define s (string-append - " ╔══╦══╦══╗\n" - " ║ 1║ 2║ 3║\n" - " ╠══╬══╩══╣\n" - " ║ 4║ ║\n" - " ╠══╣ 6 ║\n" - " ║ 5║ ║\n" - " ╚══╩═════╝\n")) - #; - (define s (string-append - " ╔══╦══╦══╗\n" - " ║1 ║2 ║3 ║\n" - " ╠══╬══╬══╣\n" - " ║6 ║5 ║4 ║\n" - " ╠══╬══╬══╣\n" - " ║7 ║8 ║9 ║\n" - " ╚══╩══╩══╝\n")) + (define s (string-append + "#2d\n" + " ╔══╦══╗\n" + " ║ ║\n" + " ╠══╬══╣\n" + " ║ ║ ║\n" + " ╚══╩══╝\n")) + (define p (open-input-string s)) (port-count-lines! p) - ;; account for the "#2dcond" that was read from the first line - (parse-2dcond p "source" 1 0 1 6)) - + (with-handlers ((exn:fail:read? exn:fail:read-srclocs)) + (parameterize ([current-readtable rt]) + (read p))) + ;; account for the "#2d" that was read from the first line + ;; (parse-2dcond p "source" 1 0 1 2) + ) + #| ╔══╦══╗ ║ ║ ║