├── .gitignore ├── 2d-doc ├── info.rkt └── scribblings │ └── 2d.scrbl ├── 2d-lib ├── cond.rkt ├── dir-chars.rkt ├── info.rkt ├── lang │ └── reader.rkt ├── lexer.rkt ├── match.rkt ├── private │ ├── lexer.rkt │ ├── read-util.rkt │ └── readtable.rkt ├── readtable.rkt └── tabular.rkt ├── 2d-test ├── info.rkt └── tests │ ├── cond-test.rkt │ ├── docs-complete.rkt │ ├── info.rkt │ ├── lexer-stress-test.rkt │ ├── lexer-test.rkt │ ├── match-test.rkt │ └── readtable-test.rkt ├── 2d └── info.rkt ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /2d-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "2d") 4 | (define version "1.0") 5 | (define deps '("base" "2d-lib")) 6 | (define build-deps '("scribble-lib" 7 | "racket-doc" 8 | "syntax-color-doc" 9 | "syntax-color-lib")) 10 | (define pkg-desc "Documentation part of \"2d\"") 11 | (define pkg-authors '(robby)) 12 | 13 | (define scribblings '(("scribblings/2d.scrbl" () ("Syntax Extensions")))) 14 | 15 | (define license 16 | '(Apache-2.0 OR MIT)) 17 | -------------------------------------------------------------------------------- /2d-doc/scribblings/2d.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/base 3 | scribble/manual 4 | scribble/core 5 | scribble/example 6 | (for-label 2d/cond 7 | 2d/match 8 | syntax-color/lexer-contract 9 | racket/file 10 | racket/contract 11 | racket/base)) 12 | 13 | @title[#:tag "2d"]{2D Syntax} 14 | 15 | @defmodulelang[2d]{The @racketmodname[2d] language installs 16 | @litchar{#2d} reader support in the 17 | @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{readtables}, 18 | and then chains to the reader of 19 | another language that is specified immediately after 20 | @racketmodname[2d].} 21 | 22 | The @litchar{#2d} syntax extension adds the ability use 23 | a two-dimensional grid syntax. That is, you can draw an ASCII-art 24 | grid and then treat that as an expression. For example, 25 | here is a simple equality function that operates on pairs and 26 | numbers, written using a @litchar{#2d} conditional expression: 27 | @codeblock{ 28 | #lang 2d racket 29 | (require 2d/cond) 30 | 31 | (define (same? a b) 32 | #2dcond 33 | ╔═════════════╦═══════════════════════╦═════════════╗ 34 | ║ ║ (pair? a) ║ (number? a) ║ 35 | ╠═════════════╬═══════════════════════╬═════════════╣ 36 | ║ (pair? b) ║ (and (same? (car a) ║ #f ║ 37 | ║ ║ (car b)) ║ ║ 38 | ║ ║ (same? (cdr a) ║ ║ 39 | ║ ║ (cdr b))) ║ ║ 40 | ╠═════════════╬═══════════════════════╬═════════════╣ 41 | ║ (number? b) ║ #f ║ (= a b) ║ 42 | ╚═════════════╩═══════════════════════╩═════════════╝) 43 | } 44 | 45 | This notation works in two stages: reading, and parsing (just as in 46 | Racket in general). The reading stage converts anything that begins 47 | with @litchar{#2d} into a parenthesized expression (possibly signaling 48 | errors if the @litchar{═} and @litchar{║} and @litchar{╬} 49 | characters do not line up in the right places). 50 | 51 | Since the first line contains @litchar{#2dcond}, the reader will 52 | produce a sequence whose first position is the identifier @racket[2dcond]. 53 | 54 | That macro will take over and then expand into ordinary conditional 55 | expressions, in this case figuring out whether or not the inputs 56 | are pairs or numbers and evaluating the code in the appropriate cell. 57 | 58 | At the reader level, the syntax @litchar{#2d} notation checks 59 | the number of columns in the first row and uses that as a guide 60 | for where subsequent rows may appear. Once that first row is set, 61 | it serves as a guide to where the columns may appear in subsequent 62 | rows, although following columns may be merged. 63 | 64 | This merging can simplify 65 | some uses of @litchar{#2d} expressions. For example, consider this 66 | expression that captures subtyping relationships between a few of the 67 | Typed Racket numeric types, this time using a @litchar{#2d} match 68 | expression: 69 | @codeblock{ 70 | #lang 2d racket 71 | (require 2d/match) 72 | 73 | (define (subtype? a b) 74 | #2dmatch 75 | ╔══════════╦══════════╦═══════╦══════════╗ 76 | ║ a b ║ 'Integer ║ 'Real ║ 'Complex ║ 77 | ╠══════════╬══════════╩═══════╩══════════╣ 78 | ║ 'Integer ║ #t ║ 79 | ╠══════════╬══════════╗ ║ 80 | ║ 'Real ║ ║ ║ 81 | ╠══════════╣ ╚═══════╗ ║ 82 | ║ 'Complex ║ #f ║ ║ 83 | ╚══════════╩══════════════════╩══════════╝) 84 | } 85 | 86 | There are a number of cell walls missing here, but this is still a 87 | well-formed @litchar{#2d} expression. In this case, the @racket[2dmatch] 88 | treats any of the situations that fall into the larger regions as 89 | the same. 90 | 91 | In general, a @litchar{#2d} expression, when read, turns into an expression 92 | with at least two sub-pieces (not counting the initial name). The first is 93 | a sequence of numbers giving the widths of the top row of cells; 94 | the second is also a sequence of numbers, this time giving the heights 95 | of the leftmost column of cells. The remaining sequence describe the cells 96 | content. The first element of each is itself a sequence of coordinates, 97 | one for each of the cells that are connected together. The remaining elements 98 | are the subexpressions in the given cells. 99 | 100 | For example, this: 101 | 102 | @codeblock{ 103 | #lang 2d racket 104 | '#2dex 105 | ╔══════════╦══════════╗ 106 | ║ 0 ║ 1 ║ 107 | ╠══════════╬══════════╣ 108 | ║ 2 ║ 3 ║ 109 | ╚══════════╩══════════╝ 110 | } 111 | 112 | evaluates to 113 | @racketblock['(2dex (10 10) 114 | (2 2) 115 | (((0 0)) 0) 116 | (((0 1)) 2) 117 | (((1 0)) 1) 118 | (((1 1)) 3))] 119 | 120 | and this 121 | @codeblock{ 122 | #lang 2d racket 123 | '#2dex 124 | ╔══════════╦══════════╦══════════╗ 125 | ║ 0 ║ 1 2 ║ 3 4 ║ 126 | ╠══════════╬══════════╩══════════╣ 127 | ║ 5 ║ 6 ║ 128 | ╚══════════╩═════════════════════╝ 129 | } 130 | evaluates to 131 | @racketblock['(2dex (10 10 10) 132 | (2 2) 133 | (((0 0)) 0) 134 | (((0 1)) 5) 135 | (((1 0)) 1 2) 136 | (((1 1) (2 1)) 6) 137 | (((2 0)) 3 4))] 138 | 139 | In addition, the cells coordinates pairs have source locations of the first 140 | character that is inside the corresponding cell. (Currently the span 141 | is always @racket[1], but that may change.) 142 | 143 | @section{Editing 2D} 144 | 145 | DrRacket provides a number of keybindings to help editing @litchar{#2d} expressions. 146 | See @seclink["Keyboard Shortcuts" #:doc '(lib "scribblings/drracket/drracket.scrbl") #:indirect? #t]{DrRacket's keyboard shortcuts}. 147 | 148 | @section{2D Cond} 149 | 150 | @defmodule[2d/cond] 151 | 152 | @defform/subs[(2dcond cond-content) 153 | ([cond-content (code:line question-row 154 | body-row 155 | ⋮) 156 | (code:line question-row 157 | body-row 158 | ⋮ 159 | else-row)] 160 | [question-row (code:line empty-cell question-cell ⋯) 161 | (code:line empty-cell question-cell ⋯ else-cell)] 162 | [body-row (code:line question-cell exprs-cell ⋯)] 163 | [else-row (code:line question-cell exprs-cell ⋯ else-cell)] 164 | [question-cell (code:line ╔═════════════╗ 165 | ║question-expr║ 166 | ╚═════════════╝)] 167 | 168 | [empty-cell (code:line ╔═══╗ 169 | ║ ║ 170 | ╚═══╝)] 171 | 172 | [exprs-cell (code:line ╔═════════════╗ 173 | ║expr expr ...║ 174 | ╚═════════════╝)] 175 | [else-cell (code:line ╔══════╗ 176 | ║ else ║ 177 | ╚══════╝)])]{ 178 | Evaluates the first row of question expressions until 179 | one of them returns a true value (signaling an error if none do), 180 | then evaluates the first column of question expressions until 181 | one of them returns a true value (signaling an error if none do), 182 | and then evaluates the cell in the middle where both point to, 183 | returning the result of the last expression in that cell. 184 | } 185 | 186 | @section{2D Match} 187 | 188 | @defmodule[2d/match] 189 | 190 | @defform/subs[(2dmatch match-content) 191 | ([match-content (code:line match-first-row 192 | match-row 193 | ⋮)] 194 | [match-first-row (code:line two-expr-cell match-pat-cell ⋯)] 195 | [match-row (code:line match-pat-cell exprs-cell ⋯)] 196 | [two-expr-cell (code:line ╔═════════════════╗ 197 | ║col-expr row-expr║ 198 | ╚═════════════════╝)] 199 | 200 | [match-pat-cell (code:line ╔═════╗ 201 | ║ pat ║ 202 | ╚═════╝)] 203 | 204 | [exprs-cell (code:line ╔═════════════╗ 205 | ║expr expr ...║ 206 | ╚═════════════╝)])]{ 207 | Matches @racket[col-expr] against each of patterns 208 | in the first column of the table and matches @racket[row-expr] 209 | against each of the patterns in the row row, and then evaluates 210 | the corresponding @racket[exprs-cell], returning the value of the 211 | last expression in that cell. 212 | 213 | Within the top-left cell, the leftmost expression will count as 214 | @racket[col-expr], and the rightmost as @racket[row-expr]. In case of a tie 215 | (i.e., both expressions start at the same column, but on different lines), 216 | the bottommost one will count as @racket[col-expr]. For example, all of 217 | these are valid: 218 | 219 | @racketblock[╔═════════════════╗ 220 | ║col-expr row-expr║ 221 | ╚═════════════════╝] 222 | @racketblock[╔═════════════════╗ 223 | ║ row-expr║ 224 | ║col-expr ║ 225 | ╚═════════════════╝] 226 | @racketblock[╔════════╗ 227 | ║row-expr║ 228 | ║col-expr║ 229 | ╚════════╝] 230 | 231 | @history[#:changed "6.4"]{Made scrutinee parsing more flexible.} 232 | } 233 | 234 | @section{2D Tabular} 235 | 236 | @defmodule[2d/tabular] 237 | 238 | @defform/subs[(2dtabular tabular-content) 239 | 240 | ([tabular-content (code:line tabular-row 241 | ⋮) 242 | (code:line tabular-row 243 | ⋮ 244 | style-cell)] 245 | [tabular-row (code:line tabular-cell ⋯)] 246 | [tabular-cell (code:line ╔════════════════╗ 247 | ║tabular-expr ...║ 248 | ╚════════════════╝)] 249 | [style-cell (code:line ╔═════════════════╗ 250 | ║style-content ...║ 251 | ╚═════════════════╝)] 252 | [style-content (code:line #:style style-expr) 253 | (code:line #:sep sep-expr) 254 | #:ignore-first-row]) 255 | 256 | #:contracts ([style-expr style?] 257 | [sep-expr (or/c block? content? #f)] 258 | [tabular-expr (or/c block? content?)])]{ 259 | Constructs a @racket[tabular] matching the given cells. 260 | 261 | If a cell spans multiple columns, then the resulting 262 | @racket[tabular] has @racket['cont] in the corresponding 263 | list element. No cells may span rows. 264 | 265 | The @racket[#:style] and @racket[#:sep] arguments are just passed 266 | to @racket[tabular]. 267 | 268 | If the @racket[#:ignore-first-row] keyword is provided, then the first 269 | row of the @racket[2dtabular] expression is ignored. This can be used 270 | in case the first row of the rendered table should not have all of the 271 | columns (as @litchar{#2d} syntax requires that the first row contain 272 | a cell for each column that appears in the table). 273 | } 274 | 275 | @section{2D Readtable} 276 | 277 | @defmodule[2d/readtable] 278 | 279 | @defproc[(make-readtable) readtable?]{ 280 | Builds a @racket[readtable?] that recognizes @litchar{#2d} and turns it into 281 | a parenthesized form as discussed in @secref["2d"]. 282 | } 283 | 284 | @defproc[(2d-readtable-dispatch-proc 285 | [char char?] 286 | [port input-port?] 287 | [source any/c] 288 | [line (or/c exact-positive-integer? #f)] 289 | [column (or/c exact-nonnegative-integer? #f)] 290 | [position (or/c exact-positive-integer? #f)] 291 | [/recursive (-> input-port? any/c (or/c readtable? #f) any/c)] 292 | [readtable (or/c #f readtable?)]) 293 | any/c]{ 294 | The function that implements @racket[make-readtable]'s functionality. The 295 | @racket[/recursive] function is used to handle the content in the cells. 296 | 297 | See the docs 298 | on @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{readtables} for more information. 299 | } 300 | 301 | @section{2d Lexer} 302 | 303 | @defmodule[2d/lexer] 304 | 305 | @defproc[(2d-lexer [sub lexer/c]) lexer/c]{ 306 | Constructs a @racket[lexer/c] given one that handles 307 | lexing inside the cells. 308 | } 309 | 310 | @section{2D Direction Chars} 311 | 312 | @defmodule[2d/dir-chars] 313 | 314 | @(define 2dchars-eval (make-base-eval '(require 2d/dir-chars))) 315 | 316 | This library provides definitions of the characters that are looked for when 317 | parsing 2d syntax. 318 | 319 | @(define-syntax-rule 320 | (doc-chars id . stuff) 321 | (begin 322 | @(defthing id (listof char?) . stuff) 323 | @examples[#:label #f #:eval 2dchars-eval id])) 324 | 325 | @doc-chars[adjustable-chars]{ 326 | These are the characters that are considered either to be part of 2d rectangle 327 | or characters that could be part of one, possibly fixed by up a DrRacket keybinding. 328 | } 329 | 330 | @doc-chars[double-barred-chars]{ 331 | These are all of the @racket[adjustable-chars], except those that are regular ASCII. 332 | } 333 | 334 | @doc-chars[up-chars]{ 335 | All of the 2d chars that connect to the line above. 336 | } 337 | 338 | @doc-chars[dn-chars]{ 339 | All of the 2d chars that connect to the line below. 340 | } 341 | 342 | @doc-chars[lt-chars]{ 343 | All of the 2d chars that connect to the previous char. 344 | } 345 | 346 | @doc-chars[rt-chars]{ 347 | All of the 2d chars that connect to the next char. 348 | } 349 | 350 | -------------------------------------------------------------------------------- /2d-lib/cond.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base)) 3 | 4 | (provide 2dcond) 5 | (define-syntax (2dcond stx) 6 | (syntax-case stx () 7 | [(_ widths heights 8 | [(cell ...) rhs ...] ...) 9 | (let () 10 | 11 | (define last-col (- (length (syntax->list #'widths)) 1)) 12 | (define last-row (- (length (syntax->list #'heights)) 1)) 13 | 14 | ;; coord-to-content : hash[(list num num) -o> (listof syntax)] 15 | (define coord-to-content (make-hash)) 16 | (define let-bindings '()) 17 | 18 | ;; build up the coord-to-content mapping 19 | ;; side-effect: record need for let bindings to 20 | ;; cover the the situation where multiple cells 21 | ;; are joined together 22 | (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))] 23 | [rhses (in-list (syntax->list #'((rhs ...) ...)))]) 24 | (define cells (syntax->datum cells-stx)) 25 | 26 | (cond 27 | [(member (list 0 0) cells) 28 | (unless (null? (syntax-e rhses)) 29 | (raise-syntax-error '2dcond 30 | "cell at 0,0 must be empty" 31 | stx))] 32 | [else 33 | (when (null? (syntax-e rhses)) 34 | (raise-syntax-error '2dcond 35 | (format "cell at ~a,~a must not be empty" 36 | (list-ref (car cells) 0) 37 | (list-ref (car cells) 1)) 38 | stx))]) 39 | 40 | (cond 41 | [(member (list 0 0) cells) (void)] 42 | [(and (or (member (list 0 last-row) cells) 43 | (member (list last-col 0) cells)) 44 | (syntax-case rhses (else) 45 | [(else) #t] 46 | [_ #f])) 47 | ;; found an 'else' (in a reasonable place) 48 | ;; => treat it like a #t in that cell 49 | (hash-set! coord-to-content 50 | (car cells) 51 | (list #'#t))] 52 | [(and 53 | ;; only one cell: 54 | (null? (cdr cells)) 55 | ;; not in the left-edge (questions) 56 | (not (= 0 (car (car cells))))) 57 | ;; then we don't need a let binding 58 | (hash-set! coord-to-content 59 | (car cells) 60 | (syntax->list rhses))] 61 | [else 62 | (for ([cell (in-list cells)]) 63 | (define x (list-ref cell 0)) 64 | (define y (list-ref cell 1)) 65 | (with-syntax ([(id) (generate-temporaries (list (format "2dcond~a-~a" x y)))] 66 | [(rhs ...) rhses]) 67 | (set! let-bindings (cons #`[id (λ () rhs ...)] 68 | let-bindings)) 69 | (hash-set! coord-to-content cell (list #'(id)))))])) 70 | 71 | (define num-of-cols (length (syntax->list #'widths))) 72 | (define num-of-rows (length (syntax->list #'heights))) 73 | #`(let #,let-bindings 74 | #,(for/fold ([else-branch #'(2dcond-runtime-error #f)]) 75 | ([x-flip (in-range 1 num-of-cols)]) 76 | (define x (- num-of-cols x-flip)) 77 | #`(if (let () #,@(hash-ref coord-to-content (list x 0))) 78 | (cond 79 | #,@(for/list ([y (in-range 1 num-of-rows)]) 80 | #`[(let () #,@(hash-ref coord-to-content (list 0 y))) 81 | #,@(hash-ref coord-to-content (list x y))]) 82 | [else (2dcond-runtime-error #,x)]) 83 | #,else-branch))))])) 84 | 85 | (define (2dcond-runtime-error dir) 86 | (define str 87 | (if dir 88 | (format "all of the y-direction questions were false (x coordinate ~a was true)" 89 | dir) 90 | "all of the x-direction questions were false")) 91 | (error '2dcond str)) 92 | -------------------------------------------------------------------------------- /2d-lib/dir-chars.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list) 3 | (provide adjustable-chars 4 | double-barred-chars 5 | up-chars 6 | dn-chars 7 | lt-chars 8 | rt-chars) 9 | 10 | (define up-chars 11 | '(#\╬ 12 | #\╩ #\╣ #\╠ 13 | #\╝ #\╚ 14 | #\║ 15 | #\+ #\|)) 16 | 17 | (define dn-chars 18 | '(#\╬ 19 | #\╦ #\╣ #\╠ 20 | #\╗ #\╔ 21 | #\║ 22 | #\+ #\|)) 23 | 24 | (define lt-chars 25 | '(#\╬ 26 | #\╩ #\╦ #\╣ 27 | #\╝ #\╗ 28 | #\═ 29 | #\+ #\- #\=)) 30 | 31 | (define rt-chars 32 | '(#\╬ 33 | #\╩ #\╦ #\╠ 34 | #\╔ #\╚ 35 | #\═ 36 | #\+ #\- #\=)) 37 | 38 | (define adjustable-chars 39 | (remove-duplicates 40 | (append up-chars dn-chars lt-chars rt-chars))) 41 | 42 | (define double-barred-chars 43 | (remove* '(#\+ #\- #\= #\|) 44 | adjustable-chars)) 45 | -------------------------------------------------------------------------------- /2d-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "2d") 4 | (define version "1.1") 5 | (define deps '(["base" #:version "6.90.0.19"] 6 | "scribble-lib" 7 | "syntax-color-lib")) 8 | (define pkg-desc "Implementation (no documentation) part of \"2d\"") 9 | (define pkg-authors '(robby)) 10 | 11 | (define license 12 | '(Apache-2.0 OR MIT)) 13 | -------------------------------------------------------------------------------- /2d-lib/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require syntax/module-reader 3 | (only-in "../private/readtable.rkt" make-2d-readtable)) 4 | 5 | (provide (rename-out [2d-read read] 6 | [2d-read-syntax read-syntax] 7 | [2d-get-info get-info])) 8 | 9 | (define (wrap-reader p) 10 | (lambda args 11 | (parameterize ([current-readtable (make-2d-readtable)]) 12 | (apply p args)))) 13 | 14 | (define-values (2d-read 2d-read-syntax 2d-get-info) 15 | (make-meta-reader 16 | '2d 17 | "language path" 18 | lang-reader-module-paths 19 | wrap-reader 20 | wrap-reader 21 | (lambda (proc) 22 | (lambda (key defval) 23 | (case key 24 | [(color-lexer) 25 | (define theirs 26 | (or (and proc (proc key #f)) 27 | (dynamic-require 'syntax-color/racket-lexer 'racket-lexer))) 28 | ((dynamic-require '2d/lexer '2d-lexer) theirs)] 29 | [else (if proc (proc key defval) defval)]))))) 30 | -------------------------------------------------------------------------------- /2d-lib/lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/lexer.rkt") 3 | (provide 2d-lexer) 4 | -------------------------------------------------------------------------------- /2d-lib/match.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | (only-in racket/match/parse parse) 4 | racket/match/patterns) 5 | racket/match) 6 | 7 | (provide 2dmatch) 8 | (define-syntax (2dmatch stx) 9 | (syntax-case stx () 10 | [(_ widths heights [(cell ...) rhs ...] ...) 11 | (let () 12 | 13 | ;; coord-to-content : hash[(list num num) -o> (listof syntax)] 14 | (define coord-to-content (make-hash)) 15 | 16 | ;; pattern-vars : hash[(list num num) -o> (listof identifier)] 17 | ;; for each cell on the boundary, tell us which vars are 18 | ;; bound in the corresponding pattern 19 | (define pattern-vars (make-hash)) 20 | 21 | (define let-bindings '()) 22 | 23 | (define main-args #f) 24 | 25 | (define (on-boundary? cells) 26 | (ormap (λ (lst) (or (= 0 (list-ref lst 0)) 27 | (= 0 (list-ref lst 1)))) 28 | cells)) 29 | 30 | (define (cell-stx-object cell) 31 | (if (hash-has-key? coord-to-content cell) 32 | (datum->syntax #f " " (hash-ref coord-to-content cell)) 33 | #f)) 34 | 35 | ;; build up the coord-to-content mapping for the 36 | ;; boundary cells and build up the pattern-vars table 37 | (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))] 38 | [rhses (in-list (syntax->list #'((rhs ...) ...)))]) 39 | (define cells (syntax->datum cells-stx)) 40 | (define rhses-lst (syntax->list rhses)) 41 | (cond 42 | [(member (list 0 0) cells) 43 | (unless (and rhses-lst (= 2 (length rhses-lst))) 44 | (raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions" 45 | (cell-stx-object (car cells)))) 46 | (with-syntax ([(left-x right-x) (generate-temporaries rhses)] 47 | [(first-arg second-arg) rhses]) 48 | (define-values (col-arg row-arg) 49 | (if (< (syntax-column #'first-arg) 50 | (syntax-column #'second-arg)) 51 | ;; first argument is to the left of second, first is column 52 | (values #'first-arg #'second-arg) 53 | ;; otherwise, second argument is either aligned with first 54 | ;; (in which case it's below, otherwise it wouldn't be second) 55 | ;; or second is to the left of first 56 | ;; either way, second is column 57 | (values #'second-arg #'first-arg))) 58 | (set! let-bindings (list* #`[row-x #,row-arg] 59 | #`[col-x #,col-arg] 60 | let-bindings)) 61 | (set! main-args #'(row-x col-x)))] 62 | [(on-boundary? cells) 63 | (unless (and rhses-lst (= 1 (length rhses-lst))) 64 | (raise-syntax-error '2dmatch 65 | (format 66 | "cell at ~a,~a must contain exactly one match pattern, found ~a" 67 | (list-ref (car cells) 0) (list-ref (car cells) 1) 68 | (length rhses-lst)) 69 | stx 70 | (cell-stx-object (car (syntax-e cells-stx))))) 71 | (define pat (car rhses-lst)) 72 | (hash-set! pattern-vars (car cells) (bound-vars (parse pat)))]) 73 | (when (pair? rhses-lst) 74 | (define pat (car rhses-lst)) 75 | (hash-set! coord-to-content (car cells) pat))) 76 | 77 | ;; build up the coord-to-content mapping for the non-boundary cells 78 | ;; use the pattern-vars table to build up the let-bindings that 79 | ;; bind identifiers to functions that end up getting called in the match clauses 80 | (for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))] 81 | [rhses (in-list (syntax->list #'((rhs ...) ...)))]) 82 | (define cells (syntax->datum cells-stx)) 83 | (define rhses-lst (syntax->list rhses)) 84 | (unless (on-boundary? cells) 85 | (when (null? (syntax-e rhses)) 86 | (raise-syntax-error '2dmatch 87 | (format "cell at ~a,~a should not be empty" 88 | (list-ref (car cells) 0) 89 | (list-ref (car cells) 1)) 90 | stx)) 91 | (define horizontal-vars (hash-ref pattern-vars (list (list-ref (car cells) 0) 0))) 92 | (define vertical-vars (hash-ref pattern-vars (list 0 (list-ref (car cells) 1)))) 93 | 94 | (define (intersect vs1 vs2) 95 | (for/list ([v1 (in-list vs1)] 96 | #:when (is-in? v1 vs2)) 97 | v1)) 98 | 99 | (define (is-in? v1 v2s) 100 | (for/or ([v2 (in-list v2s)]) 101 | (free-identifier=? v1 v2))) 102 | 103 | (for ([cell (in-list (cdr cells))]) 104 | (set! horizontal-vars (intersect horizontal-vars 105 | (hash-ref pattern-vars (list (list-ref cell 0) 0)))) 106 | (set! vertical-vars (intersect vertical-vars 107 | (hash-ref pattern-vars (list 0 (list-ref cell 1)))))) 108 | 109 | (with-syntax ([(id) (generate-temporaries (list (format "2d-~a-~a" 110 | (list-ref (car cells) 0) 111 | (list-ref (car cells) 1))))]) 112 | (define app #`(id #,@horizontal-vars #,@vertical-vars)) 113 | (for ([cell (in-list cells)]) 114 | (hash-set! coord-to-content cell app)) 115 | (set! let-bindings 116 | (cons #`[id #,(syntax-property 117 | #`(λ (#,@horizontal-vars #,@vertical-vars) #,@rhses) 118 | 'typechecker:called-in-tail-position 119 | #t)] 120 | let-bindings))))) 121 | 122 | (define num-of-cols (length (syntax->list #'widths))) 123 | (define num-of-rows (length (syntax->list #'heights))) 124 | #`(let #,(reverse let-bindings) 125 | (match*/derived #,main-args #,stx 126 | #,@(for*/list ([x (in-range 1 num-of-cols)] 127 | [y (in-range 1 num-of-rows)]) 128 | #`[(#,(hash-ref coord-to-content (list x 0)) 129 | #,(hash-ref coord-to-content (list 0 y))) 130 | #,(hash-ref coord-to-content (list x y))]))))])) 131 | -------------------------------------------------------------------------------- /2d-lib/private/lexer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "read-util.rkt" 3 | "../dir-chars.rkt" 4 | racket/set 5 | racket/port 6 | racket/contract 7 | syntax-color/lexer-contract) 8 | 9 | #| 10 | 11 | todo: 12 | - break up the table into pieces 13 | to better cope with edits 14 | 15 | |# 16 | 17 | (provide (contract-out [2d-lexer (-> lexer*/c lexer*/c)]) 18 | cropped-regions) 19 | 20 | (define (2d-lexer chained-lexer) 21 | (define uniform-chained-lexer 22 | (cond 23 | [(procedure-arity-includes? chained-lexer 3) 24 | chained-lexer] 25 | [else 26 | (λ (port offset mode) 27 | (define-values (val tok paren start end) (chained-lexer port)) 28 | (values val tok paren start end 0 #f))])) 29 | (define (2dcond-lexer port offset _mode) 30 | (define a-2d-lexer-state (or _mode (2d-lexer-state '() #f #f))) 31 | (cond 32 | [(pair? (2d-lexer-state-pending-tokens a-2d-lexer-state)) 33 | (define-values (line col pos) (port-next-location port)) 34 | (define-values (val tok paren start end) 35 | (apply values (car (2d-lexer-state-pending-tokens a-2d-lexer-state)))) 36 | 37 | ;; this helper function checks to make sure that what's 38 | ;; in the port is actually what was predicted by the 39 | ;; 'val' -- it isn't necessary for correct operation, but 40 | ;; helps find bugs earlier 41 | (define (check-char i c2) 42 | ;; here we want to check to make sure we're in sync, but 43 | ;; we cannot count on the lexers to return the same strings 44 | ;; as we saw in the port in general. So, instead we check only 45 | ;; when the token is a parenthesis and the characters are 46 | ;; the double-barred chars (since we made that token) 47 | (when (and (equal? tok 'parenthesis) 48 | (regexp-match? all-double-barred-chars-regexp val)) 49 | (define c1 (string-ref val i)) 50 | (unless (equal? c1 c2) 51 | (error '2d/lexer.rkt "expected a ~s, got ~s while feeding token ~s" 52 | c1 c2 53 | (car (2d-lexer-state-pending-tokens a-2d-lexer-state)))))) 54 | 55 | ;; actually read the characters in 56 | (define last-i (- end start)) 57 | (let loop ([i 0] 58 | 59 | ;; str-offset helps deal with the way line-counting ports handle 60 | ;; \r\n combinations. That is, (- end start) will be a number that 61 | ;; doesn't match the length of the string in the case that there 62 | ;; are \r\n pairs in the port. We'll increment str-offset for each 63 | ;; of those and then use str-offset when indexing into the string 64 | [str-offset 0]) 65 | (unless (= i last-i) 66 | (define c2 (read-char-or-special port)) 67 | (check-char (+ str-offset i) c2) 68 | (cond 69 | [(and (equal? c2 #\return) 70 | (equal? (peek-char-or-special port) #\newline)) 71 | (read-char-or-special port) 72 | (check-char (+ str-offset i 1) #\newline) 73 | (loop (+ i 1) 74 | (+ str-offset 1))] 75 | [else 76 | (loop (+ i 1) 77 | str-offset)]))) 78 | 79 | (define next-tokens 80 | (cdr (2d-lexer-state-pending-tokens 81 | a-2d-lexer-state))) 82 | (define new-state 83 | (struct-copy 2d-lexer-state 84 | a-2d-lexer-state 85 | [pending-tokens next-tokens])) 86 | (values val tok paren 87 | pos 88 | (+ (- end start) pos) 89 | start 90 | (if (null? next-tokens) 91 | new-state 92 | (dont-stop new-state)))] 93 | [(equal? #\# (peek-char-or-special port)) 94 | (define pp (peeking-input-port port)) 95 | (define chars (list (read-char-or-special pp) 96 | (read-char-or-special pp) 97 | (read-char-or-special pp))) 98 | (cond 99 | [(equal? chars '(#\# #\2 #\d)) 100 | (start-new-2d-cond-lexing port a-2d-lexer-state uniform-chained-lexer offset)] 101 | [else 102 | (call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state)])] 103 | [else 104 | (call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state)])) 105 | 2dcond-lexer) 106 | 107 | 108 | (define double-barred-chars-regexp 109 | (regexp 110 | (format "[~a]" (apply string double-barred-chars)))) 111 | (define all-double-barred-chars-regexp 112 | (regexp 113 | (format "^[~a]*$" (apply string double-barred-chars)))) 114 | 115 | (define (call-chained-lexer uniform-chained-lexer port offset a-2d-lexer-state) 116 | (define-values (a b c d e f new-mode) 117 | (uniform-chained-lexer port offset (2d-lexer-state-chained-state a-2d-lexer-state))) 118 | (values a b c d e f (2d-lexer-state '() #f new-mode))) 119 | 120 | (struct 2d-lexer-state (pending-tokens read-state chained-state)) 121 | 122 | (define (start-new-2d-cond-lexing port a-2d-lexer-state uniform-chained-lexer offset) 123 | (define-values (line col pos) (port-next-location port)) 124 | ;; consume #\# #\2 and #\d that must be there (peeked them earlier) 125 | (read-char-or-special port) 126 | (read-char-or-special port) 127 | (read-char-or-special port) 128 | ;; read in the keyword and get those tokens 129 | 130 | (define-values (backwards-chars eol-string) 131 | (let loop ([kwd-chars '(#\d #\2 #\#)]) 132 | (define c (peek-char port)) 133 | (cond [(eof-object? c) (values kwd-chars "")] 134 | [(and (equal? c #\return) 135 | (equal? (peek-char port 1) #\newline)) 136 | (values kwd-chars (string c #\newline))] 137 | [(or (equal? c #\return) 138 | (equal? c #\newline)) 139 | (values kwd-chars (string c))] 140 | [else 141 | (read-char-or-special port) ;; actually get the char 142 | (loop (cons c kwd-chars))]))) 143 | (define first-tok-string 144 | (apply string (reverse backwards-chars))) 145 | (cond 146 | [(eof-object? (peek-char port)) 147 | (values first-tok-string 148 | 'error 149 | #f 150 | pos 151 | (+ pos (string-length first-tok-string)) 152 | 0 153 | a-2d-lexer-state)] 154 | [else 155 | (define base-position 156 | ;; one might think that this should depend on the length of eol-string 157 | ;; but ports that have port-count-lines! enabled count the \r\n combination 158 | ;; as a single position in the port, not two. 159 | (let-values ([(_1 _2 c-pos) (port-next-location port)]) 160 | c-pos)) 161 | (define peek-port (peeking-input-port port)) 162 | ;; pull the newline out of the peek-port 163 | (for ([x (in-range (string-length eol-string))] 164 | [c1 (in-string eol-string)]) 165 | (define c2 (read-char-or-special peek-port)) 166 | (unless (equal? c1 c2) 167 | (error '2d/lexer.rkt "got an unexpected char.1 ~s vs ~s" c1 c2))) 168 | 169 | (define the-state (make-state line pos (string-length first-tok-string))) 170 | (setup-state the-state) 171 | 172 | ;; would like to be able to stop this loop 173 | ;; and process only part of the table, 174 | ;; but that works only when there are no broken 175 | ;; edges of the table that span the place I want to stop. 176 | (define failed 177 | (with-handlers ((exn:fail:read? values)) 178 | (let loop ([map #f]) 179 | (define new-map 180 | (parse-2dcond-one-step peek-port (object-name peek-port) #f #f pos the-state map)) 181 | (when new-map 182 | (loop new-map))))) 183 | 184 | (define newline-token 185 | (list eol-string 'white-space #f 186 | (+ pos (string-length first-tok-string)) 187 | ;; no matter how long eol-string is, it counts for 1 position only. 188 | (+ pos (string-length first-tok-string) 1))) 189 | 190 | (cond 191 | [(exn:fail:read:eof? failed) 192 | ;; in this case, the source location for the error 193 | ;; should be the beginning of the #2d token, 194 | ;; so we just turn the whole thing red in a single token 195 | (define tok-string 196 | (string-append 197 | first-tok-string 198 | (apply string 199 | (let loop () 200 | (define c (read-char port)) 201 | (cond 202 | [(eof-object? c) '()] 203 | [else (cons c (loop))]))))) 204 | (values tok-string 'error #f 205 | pos (+ pos (string-length tok-string)) 206 | 0 207 | #f)] 208 | [else 209 | (define final-tokens 210 | (cond 211 | [(exn:fail:read? failed) 212 | (define error-pos (- (srcloc-position (car (exn:fail:read-srclocs failed))) 213 | base-position)) ;; account for the newline 214 | (when (< error-pos 0) 215 | (error '2d/lexer.rkt "got error-pos < 0: ~s ~s" 216 | (srcloc-position (car (exn:fail:read-srclocs failed))) 217 | base-position)) 218 | (define peek-port2 (peeking-input-port port)) 219 | (port-count-lines! peek-port2) 220 | (define (pull-chars n) 221 | (apply 222 | string 223 | (let loop ([n n]) 224 | (cond 225 | [(zero? n) '()] 226 | [else 227 | (define c (read-char-or-special peek-port2)) 228 | (cond 229 | [(char? c) 230 | (cons c (loop (- n 1)))] 231 | [else 232 | ;; drop replace specials with spaces 233 | (cons #\space (loop (- n 1)))])])))) 234 | 235 | ;; pull the newline out of peek-port2 236 | (for ([x (in-range (string-length eol-string))]) (read-char-or-special peek-port2)) 237 | 238 | (define before-token (list (pull-chars error-pos) 239 | 'no-color 240 | #f 241 | (+ base-position 1) 242 | (+ base-position 1 error-pos))) 243 | (define end-of-table-approx 244 | (let ([peek-port3 (peeking-input-port peek-port2)]) 245 | (port-count-lines! peek-port3) 246 | (define (read-line/check-double-barred) 247 | (let loop ([found-double-barred? #f]) 248 | (define c (read-char-or-special peek-port3)) 249 | (cond 250 | [(or (equal? c #\n) (eof-object? c)) 251 | found-double-barred?] 252 | [else (loop (or found-double-barred? 253 | (member c double-barred-chars)))]))) 254 | (let loop () 255 | (define found-double-barred? (read-line/check-double-barred)) 256 | (cond 257 | [found-double-barred? 258 | (loop)] 259 | [else 260 | (define-values (line col pos) (port-next-location peek-port3)) 261 | pos])))) 262 | (define after-token 263 | (list (pull-chars (- end-of-table-approx 1)) 264 | 'error 265 | #f 266 | (+ base-position 1 error-pos) 267 | (+ base-position 1 error-pos end-of-table-approx -1))) 268 | (if (zero? error-pos) 269 | (list newline-token after-token) 270 | (list newline-token before-token after-token))] 271 | [else 272 | 273 | (define lhses (close-cell-graph cell-connections 274 | (length table-column-breaks) 275 | (length rows))) 276 | (define scratch-string (make-string (for/sum ([ss (in-list rows)]) 277 | (for/sum ([s (in-list ss)]) 278 | (string-length s))) 279 | #\space)) 280 | (define collected-tokens '()) 281 | (define rows-as-vector (apply vector (reverse rows))) 282 | (for ([set-of-indicies (in-list (sort (set->list lhses) compare/xy 283 | #:key smallest-representative))]) 284 | (define regions 285 | (fill-scratch-string set-of-indicies 286 | rows-as-vector 287 | scratch-string 288 | table-column-breaks 289 | initial-space-count 290 | #t)) 291 | (define port (open-input-string scratch-string)) 292 | (port-count-lines! port) 293 | (let loop ([mode (2d-lexer-state-chained-state a-2d-lexer-state)]) 294 | (define-values (_1 _2 current-pos) (port-next-location port)) 295 | (define-values (tok-str tok paren start end backup new-mode) 296 | (uniform-chained-lexer port (+ pos offset) mode)) 297 | (unless (equal? 'eof tok) 298 | (for ([sub-region (in-list (cropped-regions start end regions))]) 299 | (define start (- (car sub-region) current-pos)) 300 | (define end (- (cdr sub-region) current-pos)) 301 | (set! collected-tokens 302 | (cons (list (if (and (string? tok-str) 303 | (< start (string-length tok-str)) 304 | (<= end (string-length tok-str))) 305 | (substring tok-str start end) 306 | (list 'strange-token tok-str)) 307 | tok 308 | paren 309 | (+ base-position (car sub-region)) 310 | (+ base-position (cdr sub-region))) 311 | collected-tokens))) 312 | (loop new-mode)))) 313 | 314 | (define (collect-double-barred-token pending-start i offset str) 315 | (when pending-start 316 | (set! collected-tokens (cons (list (substring str pending-start i) 317 | 'parenthesis 318 | #f 319 | (+ base-position offset pending-start) 320 | (+ base-position offset i)) 321 | collected-tokens)))) 322 | 323 | (for/fold ([offset 1]) ([strs (in-list (reverse (cons (list current-line) rows)))]) 324 | (for/fold ([offset offset]) ([str (in-list strs)]) 325 | (let loop ([i 0] 326 | [pending-start #f]) 327 | (cond 328 | [(< i (string-length str)) 329 | (define c (string-ref str i)) 330 | (cond 331 | [(member c double-barred-chars) 332 | (loop (+ i 1) 333 | (if pending-start pending-start i))] 334 | [else 335 | (collect-double-barred-token pending-start i offset str) 336 | (loop (+ i 1) #f)])] 337 | [else 338 | (collect-double-barred-token pending-start i offset str)])) 339 | (+ (string-length str) offset))) 340 | 341 | (define sorted-tokens (sort collected-tokens < 342 | #:key (λ (x) (list-ref x 3)))) 343 | 344 | ;; there will be gaps that correspond to the places outside of the 345 | ;; outermost rectangle (at a minimum, newlines); this fills those 346 | ;; in with whitespace tokens 347 | ;; NOTE: this code does not deal properly with \r\n newline combinations 348 | (define cracks-filled-in-tokens 349 | (let loop ([fst newline-token] 350 | [tokens sorted-tokens]) 351 | (cond 352 | [(null? tokens) (list fst)] 353 | [else 354 | (define snd (car tokens)) 355 | (cond 356 | [(= (list-ref fst 4) 357 | (list-ref snd 3)) 358 | (cons fst (loop snd (cdr tokens)))] 359 | [else 360 | (define new-start (list-ref fst 4)) 361 | (define new-end (list-ref snd 3)) 362 | (list* fst 363 | (list 364 | ; these are not the real characters ... 365 | (make-string (- new-end new-start) #\space) 366 | 'white-space 367 | #f 368 | new-start 369 | new-end) 370 | (loop snd (cdr tokens)))])]))) 371 | cracks-filled-in-tokens])) 372 | 373 | (values first-tok-string 'hash-colon-keyword #f 374 | pos (+ pos (string-length first-tok-string)) 375 | 0 376 | (dont-stop 377 | (2d-lexer-state final-tokens 378 | #t 379 | (2d-lexer-state-chained-state a-2d-lexer-state))))])])) 380 | 381 | (define (cropped-regions start end regions) 382 | (define result-regions '()) 383 | (define (add start end) 384 | (unless (= start end) 385 | (set! result-regions (cons (cons start end) result-regions)))) 386 | (let loop ([regions regions] 387 | [start start] 388 | [end end]) 389 | (unless (null? regions) 390 | (define region (car regions)) 391 | (cond 392 | [(<= start (car region)) 393 | (cond 394 | [(<= end (car region)) 395 | (void)] 396 | [(<= end (cdr region)) 397 | (add (car region) end)] 398 | [else 399 | (add (car region) (cdr region)) 400 | (loop (cdr regions) 401 | (cdr region) 402 | end)])] 403 | [(<= start (cdr region)) 404 | (cond 405 | [(<= end (cdr region)) 406 | (add start end)] 407 | [else 408 | (add start (cdr region)) 409 | (loop (cdr regions) 410 | (cdr region) 411 | end)])] 412 | [else 413 | (loop (cdr regions) start end)]))) 414 | result-regions) 415 | 416 | 417 | #| 418 | (define scratch-string (make-string (for/sum ([ss (in-vector lines)]) 419 | (for/sum ([s (in-list ss)]) 420 | (string-length s))) 421 | #\space)) 422 | 423 | (define heights 424 | (for/list ([line (in-vector lines)]) 425 | (length line))) 426 | 427 | `(,(string->symbol (string-append "2d" (apply string kwd-chars))) 428 | 429 | ,table-column-breaks 430 | ,heights 431 | 432 | ,@(for/list ([set-of-indicies (in-list (sort (set->list lhses) compare/xy 433 | #:key smallest-representative))]) 434 | (fill-scratch-string set-of-indicies 435 | lines 436 | scratch-string 437 | table-column-breaks 438 | initial-space-count) 439 | (define scratch-port (open-input-string scratch-string)) 440 | (when post-2d-line (port-count-lines! scratch-port)) 441 | (set-port-next-location! scratch-port post-2d-line post-2d-col post-2d-span) 442 | `[,(sort (set->list set-of-indicies) compare/xy) 443 | ,@(read-subparts source scratch-port 444 | initial-space-count table-column-breaks heights set-of-indicies 445 | previous-readtable /recursive)])) 446 | |# 447 | 448 | #; 449 | (module+ main 450 | (define p (open-input-string (string-append 451 | "╔══╦══╗\n" 452 | "║1 ║2 ║\n" 453 | "╠══╬══╣\n" 454 | "║4 ║3 ║\n" 455 | "╚══╩══╝\n"))) 456 | (port-count-lines! p) 457 | ;; account for the "#2d" that was read from the first line 458 | (call-with-values (λ () (tokenize-2dcond p "source" 1 0 1 2)) 459 | list)) 460 | -------------------------------------------------------------------------------- /2d-lib/private/read-util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | #| 3 | 4 | ideas: 5 | - 2dcond 6 | - 2dmatch 7 | - literal tables in scribble layout? 8 | - something for 2d graphics? 9 | 10 | example uses: 11 | - unifier 12 | - subtyping relation 13 | - merge (from merge-sort) 14 | 15 | |# 16 | 17 | (require racket/port 18 | syntax/readerr 19 | racket/match 20 | racket/set 21 | ;syntax/rect 22 | "../dir-chars.rkt" 23 | (for-syntax racket/base 24 | racket/list)) 25 | 26 | 27 | (provide parse-2dcond 28 | parse-2dcond-one-step 29 | 30 | setup-state 31 | make-state 32 | copy-state 33 | 34 | chars->desc 35 | smallest-representative 36 | all-line-of-interest 37 | current-lines 38 | close-cell-graph 39 | compare/xy 40 | fill-scratch-string) 41 | 42 | (define all-line-of-interest (make-hash)) 43 | (define current-lines (make-parameter #f)) 44 | (define-syntax (line-of-interest stx) 45 | (with-syntax ([line (syntax-line stx)]) 46 | (syntax-local-lift-expression #'(hash-set! all-line-of-interest line #t)) 47 | #'(visited line))) 48 | (define (visited line) 49 | (define t (current-lines)) 50 | (when t 51 | (hash-remove! t line))) 52 | 53 | ;; fill-scratch-string : (setof (list/c number? number?)) 54 | ;; (vector (listof string?)) 55 | ;; (or/c string? #f) 56 | ;; (listof number) 57 | ;; number 58 | ;; [boolean?] 59 | ;; -> (if scratch-string 60 | ;; (listof (cons/c number? number?)) 61 | ;; void?) 62 | ;; scratch-string gets filled in from the 'lines' argument. 63 | ;; If compute-regions? is #t, then this function constructs the regions of the 64 | ;; string that are have been filled in (as a list of pairs of start/end coordinates) 65 | ;; and returns that (not counting the regions outside of the table to the right-- 66 | ;; these get filled in to the string, but the regions are not included) 67 | ;; the resulting regions are sorted (smaller to bigger values) and non-overlapping 68 | (define (fill-scratch-string set-of-indicies 69 | lines 70 | scratch-string 71 | table-column-breaks 72 | initial-space-count 73 | [compute-regions? #f]) 74 | 75 | (define scratch-pos 0) 76 | 77 | (define eols '()) 78 | (define segments '()) 79 | (define cur-seg-start #f) 80 | (define cur-seg-end #f) 81 | (define (add-keeper) 82 | (cond 83 | [(equal? cur-seg-end scratch-pos) 84 | (set! cur-seg-end (+ cur-seg-end 1))] 85 | [else 86 | (record-position) 87 | (set! cur-seg-start scratch-pos) 88 | (set! cur-seg-end (+ scratch-pos 1))])) 89 | (define (record-position) 90 | (when (and cur-seg-start cur-seg-end) 91 | ;; port positions count from 1, but here 92 | ;; we're counting from 0 in the string, so inc 93 | (set! segments (cons (cons (+ cur-seg-start 1) 94 | (+ cur-seg-end 1)) 95 | segments)))) 96 | 97 | (define-syntax-rule 98 | (set-scratch! in? c) 99 | (begin 100 | (let ([x c]) 101 | ;(unless (char-whitespace? x) (printf "putting ~s @ ~s\n" x scratch-pos)) 102 | (string-set! scratch-string scratch-pos x)) 103 | (when in? (when compute-regions? (add-keeper))))) 104 | (define-syntax-rule 105 | (clear-scratch!) 106 | (when scratch-string (string-set! scratch-string scratch-pos #\space))) 107 | (define-syntax-rule 108 | (inc-scratch-pos! e) 109 | (set! scratch-pos (+ scratch-pos e))) 110 | (for ([lines (in-vector lines)] 111 | [y (in-naturals)]) 112 | (for ([line (in-list lines)] 113 | [l-num (in-naturals)]) 114 | (define first-line? (zero? l-num)) 115 | ;; skip over initial spaces: we know that the string is already right here 116 | ;; because it is initialized with spaces and never changed 117 | ;; the +1 is for the first character (in the current line) 118 | ;; of the table, which is always a table edge character 119 | (inc-scratch-pos! (+ initial-space-count 1)) 120 | (define end-of-table-position 121 | (for/fold ([start-pos-in-line (+ initial-space-count 1)]) 122 | ([table-column-break (in-list table-column-breaks)] 123 | [x (in-naturals)]) 124 | (cond 125 | [(and (set-member? set-of-indicies (list x y)) 126 | (or (not first-line?) 127 | (set-member? set-of-indicies (list x (- y 1))))) 128 | (for ([j (in-range table-column-break)]) 129 | (set-scratch! #t (string-ref line (+ j start-pos-in-line))) 130 | (inc-scratch-pos! 1)) 131 | (if (if first-line? 132 | (and (set-member? set-of-indicies (list (+ x 1) (- y 1))) 133 | (set-member? set-of-indicies (list (+ x 1) y)) 134 | (set-member? set-of-indicies (list x (- y 1)))) 135 | (set-member? set-of-indicies (list (+ x 1) y))) 136 | (set-scratch! #t (string-ref line (+ table-column-break start-pos-in-line))) 137 | (clear-scratch!)) 138 | (inc-scratch-pos! 1)] 139 | [else 140 | (for ([j (in-range table-column-break)]) 141 | (clear-scratch!) 142 | (inc-scratch-pos! 1)) 143 | (clear-scratch!) 144 | (inc-scratch-pos! 1)]) 145 | (+ start-pos-in-line table-column-break 1))) 146 | (set! eols (cons (cons end-of-table-position (string-length line)) 147 | eols)) 148 | (for ([j (in-range end-of-table-position (string-length line))]) 149 | (set-scratch! #f (string-ref line j)) 150 | (inc-scratch-pos! 1)))) 151 | 152 | (when compute-regions? 153 | (record-position) 154 | (reverse segments))) 155 | 156 | (define (compare/xy p1 p2) 157 | (cond 158 | [(= (list-ref p1 0) (list-ref p2 0)) 159 | (< (list-ref p1 1) (list-ref p2 1))] 160 | [else 161 | (< (list-ref p1 0) (list-ref p2 0))])) 162 | 163 | (define (smallest-representative set) 164 | (define lst (set->list set)) 165 | (let loop ([best (car lst)] 166 | [rest (cdr lst)]) 167 | (cond 168 | [(null? rest) best] 169 | [else 170 | (cond 171 | [(compare/xy best (car rest)) 172 | (loop best (cdr rest))] 173 | [else 174 | (loop (car rest) (cdr rest))])]))) 175 | 176 | (define (close-cell-graph edges width height) 177 | (define res (make-hash)) 178 | (for ([x (in-range width)]) 179 | (for ([y (in-range height)]) 180 | (hash-set! res (list x y) (set (list x y))))) 181 | 182 | (let loop () 183 | (define something-changed? #f) 184 | (define (add-all n1 n2) 185 | (define in-n1 (hash-ref res n1)) 186 | (define in-n2 (hash-ref res n2)) 187 | (for ([new-node (in-set in-n1)]) 188 | (unless (set-member? in-n2 new-node) 189 | (set! something-changed? #t) 190 | (hash-set! res n2 (set-add in-n2 new-node))))) 191 | 192 | (for ([(node-src nodes) (in-hash edges)]) 193 | (for ([node-dest (in-set nodes)]) 194 | (add-all node-dest node-src) 195 | (add-all node-src node-dest))) 196 | 197 | (when something-changed? (loop))) 198 | 199 | (apply set (hash-map res (λ (x y) y)))) 200 | 201 | (begin-for-syntax 202 | (define state-components 203 | ;; these are the state variables for the parse-2d-cond procedure 204 | '((current-line-number _line) 205 | (current-line-start-position (+ (or _pos 0) chars-read)) 206 | (current-line #f) 207 | (current-line-length 0) 208 | (initial-space-count 0) 209 | (initial-column-guide #f) 210 | (newline-char-count 0) 211 | (table-column-breaks '()) 212 | (table-column-guides '()) 213 | (right-edge-column #f) 214 | (pending-row '()) 215 | (rows '()) 216 | (current-row 0) 217 | (cell-connections (make-hash)) 218 | (position-of-first-cell (hash))))) 219 | 220 | (define-syntax (setup-state stx) 221 | (syntax-case stx () 222 | [(_ state-struct-id #;state-accessor #;state-mutator) 223 | #`(begin 224 | #,@(for/list ([state-component (in-list state-components)] 225 | [i (in-naturals)]) 226 | (with-syntax ([id (datum->syntax #'state-struct-id (car state-component))] 227 | [i i]) 228 | #'(define-syntax id 229 | (make-set!-transformer 230 | (λ (stx) 231 | (syntax-case stx (set!) 232 | [(set! x e) 233 | #'(state-mutator state-struct-id i e)] 234 | [x 235 | (identifier? #'x) 236 | #'(state-accessor state-struct-id i)])))))))])) 237 | 238 | (define-syntax (state-struct stx) 239 | (syntax-case stx () 240 | [(_ make-state state-accessor state-mutator copy-state) 241 | #`(begin 242 | (define-values (state-type state-constructor state? state-accessor state-mutator) 243 | (make-struct-type 'parse-2d-cond-state #f #,(length state-components) 0 #f '() #f)) 244 | (define (make-state _line _pos chars-read) 245 | (state-constructor #,@(for/list ([state-component (in-list state-components)]) 246 | (list-ref state-component 1)))) 247 | (define (copy-state the-state) 248 | (state-constructor #,@(for/list ([state-component (in-list state-components)] 249 | [i (in-naturals)]) 250 | #`(state-accessor the-state #,i)))))])) 251 | 252 | (state-struct make-state state-accessor state-mutator copy-state) 253 | 254 | (define (parse-2dcond port source _line _col _pos chars-read) 255 | (define the-state (make-state _line _pos chars-read)) 256 | (let loop ([map #f]) 257 | (define new-map 258 | (parse-2dcond-one-step port source _line _col _pos the-state map)) 259 | (cond 260 | [new-map 261 | (loop new-map)] 262 | [else 263 | (setup-state the-state) 264 | (values cell-connections 265 | (apply vector (reverse rows)) 266 | table-column-breaks 267 | initial-space-count 268 | position-of-first-cell)]))) 269 | 270 | (struct guide (char srcloc) #:transparent) 271 | 272 | 273 | ;; parse-2dcond returns four values: 274 | ;; - a hash table encoding a graph that shows where the 275 | ;; broken walls are in the 2d 276 | ;; - a vector of lists of strings containing the all of the line 277 | ;; of the table except the last one; the first string in each 278 | ;; list is the boundary line between the two rows 279 | ;; - a list of numbers showing the size of each column, not 280 | ;; counting the separator character (and not taking into 281 | ;; acount broken walls) 282 | ;; - the number of spaces to the left of the 2d (same for all lines) 283 | (define (parse-2dcond-one-step port source _line _col _pos the-state last-left-map) 284 | 285 | ;; this sets up all of the state variables so they 286 | ;; look up the fields of 'the-state' and mutate 287 | ;; the fields of 'the-state'; state-components lists 288 | ;; of the state variables and their initial values 289 | (setup-state the-state) 290 | 291 | 292 | (define (add-node col row) 293 | (define k (list col row)) 294 | (unless (hash-ref cell-connections k #f) 295 | (hash-set! cell-connections k (set)))) 296 | (define (add-edge col1 row1 col2 row2) 297 | (define (add-->edge col1 row1 col2 row2) 298 | (add-node col1 row1) 299 | (define k (list col1 row1)) 300 | (hash-set! cell-connections k (set-add (hash-ref cell-connections k) (list col2 row2)))) 301 | (add-->edge col1 row1 col2 row2) 302 | (add-->edge col2 row2 col1 row1)) 303 | 304 | (define (fetch-next-line) 305 | (when current-line 306 | (set! pending-row (cons current-line pending-row))) 307 | (set! current-line-start-position 308 | (+ current-line-start-position 309 | current-line-length 310 | newline-char-count)) 311 | (when current-line-number 312 | (set! current-line-number (+ current-line-number 1))) 313 | (define chars 314 | (let loop ([chars-read 0]) 315 | (define c (read-char-or-special port)) 316 | (cond 317 | [(eof-object? c) 318 | (raise-read-eof-error 319 | "unexpected eof; " 320 | source _line _col _pos 321 | (and _pos (- (+ current-line-start-position chars-read) _pos)))] 322 | [(not (char? c)) 323 | (readerr "unexpected special" chars-read)] 324 | [(equal? c #\return) 325 | (cond 326 | [(equal? #\newline (peek-char-or-special port)) 327 | (set! newline-char-count 2) 328 | (list c (read-char-or-special port))] 329 | [else 330 | (set! newline-char-count 1) 331 | (list c)])] 332 | [(equal? c #\newline) 333 | (set! newline-char-count 1) 334 | (list c)] 335 | [(and (equal? c #\╝) (equal? right-edge-column chars-read)) 336 | ;; if we find a ╝ at the width of the table, 337 | ;; then we don't want 338 | ;; to consume any more characters and 339 | ;; instead to allow subsequent characters 340 | ;; to be part of some other thing that's 341 | ;; being read (presumably a close paren) 342 | (set! newline-char-count 0) 343 | (list c)] 344 | [else 345 | (cons c (loop (+ chars-read 1)))]))) 346 | (set! current-line (apply string chars)) 347 | (set! current-line-length (- (string-length current-line) newline-char-count))) 348 | 349 | (define (process-first-line) 350 | (fetch-next-line) 351 | (let loop ([pos 0]) 352 | (cond 353 | [(< pos current-line-length) 354 | (cond 355 | [(equal? #\space (string-ref current-line pos)) 356 | (loop (+ pos 1))] 357 | [(equal? #\╔ (string-ref current-line pos)) 358 | (set! initial-column-guide (make-a-guide pos)) 359 | (set! initial-space-count pos)] 360 | [else 361 | (line-of-interest) 362 | (readerr "expected the first non-whitespace character in the table to be ╔" 363 | pos)])] 364 | [else 365 | (line-of-interest) 366 | (readerr "expected some non-whitespace characters in the first line of the table" 367 | 0 368 | pos)])) 369 | (let loop ([pos (+ initial-space-count 1)] 370 | [current-column-width 0] 371 | [column 0] 372 | [column-breaks '()] 373 | [column-guides '()]) 374 | (cond 375 | [(< pos current-line-length) 376 | (case (string-ref current-line pos) 377 | [(#\╦) 378 | (add-node column 0) 379 | (loop (+ pos 1) 0 (+ column 1) 380 | (cons current-column-width column-breaks) 381 | (cons (make-a-guide pos) column-guides))] 382 | [(#\═) (loop (+ pos 1) (+ current-column-width 1) column 383 | column-breaks column-guides)] 384 | [(#\╗) 385 | (add-node column 0) 386 | (whitespace-to-end (+ pos 1)) 387 | (set! table-column-breaks (reverse (cons current-column-width column-breaks))) 388 | (set! right-edge-column pos) 389 | (set! table-column-guides (reverse (cons (make-a-guide pos) column-guides)))] 390 | [else 391 | (line-of-interest) 392 | (readerr "expected only ═ ╦ and ╗ characters along the top of the grid" pos)])] 393 | [else 394 | (line-of-interest) 395 | (readerr "expected ╗ to terminate the first line" pos)]))) 396 | 397 | (define (process-a-line current-map previous-line-separator?) 398 | (fetch-next-line) 399 | ;; check leading space 400 | (let loop ([n 0]) 401 | (cond 402 | [(= n initial-space-count) (void)] 403 | [(and (< n current-line-length) 404 | (equal? #\space (string-ref current-line n))) 405 | (loop (+ n 1))] 406 | [else 407 | (line-of-interest) 408 | (readerr "expected leading space" n)])) 409 | (case (string-ref current-line initial-space-count) 410 | [(#\║) (values (continue-line current-map previous-line-separator?) #t)] 411 | [(#\╠) (values (start-new-block current-map) #f)] 412 | [(#\╚) (values (finish-table current-map) #f)] 413 | [else 414 | (line-of-interest) 415 | (readerr/expected '(#\║ #\╠ #\╚) 416 | initial-space-count 417 | #:guides (list initial-column-guide))])) 418 | 419 | (define (start-new-block previous-map) 420 | (set! current-row (+ current-row 1)) 421 | (add-node 0 current-row) 422 | 423 | (set! rows (cons (reverse pending-row) rows)) 424 | (set! pending-row '()) 425 | 426 | (let loop ([current-cell-size (car table-column-breaks)] 427 | [table-column-breaks (cdr table-column-breaks)] 428 | [pos (+ initial-space-count 1)] 429 | 430 | ;; whether or not the section of the line 431 | ;; we're currently traversing is there (or not) 432 | [cell-wall-broken? #f] 433 | 434 | ;; the srcloc of the spot that led us to the decision 435 | ;; of which boolean that cell-wall-broken? should be 436 | [cell-wall-guide (make-a-guide initial-space-count)] 437 | 438 | ;; this is the result, being built up backwards 439 | [map '()] 440 | 441 | ;; this is the map from the previous cell; 442 | ;; it tells us which characters here have to point upwards 443 | [previous-map previous-map] 444 | 445 | [current-column 0]) 446 | (cond 447 | [(zero? current-cell-size) 448 | (unless (< pos current-line-length) 449 | (line-of-interest) 450 | (readerr "line ended too soon" pos)) 451 | (define sep (string-ref current-line pos)) 452 | (cond 453 | [(and cell-wall-broken? (not (car previous-map))) 454 | (unless (equal? sep #\╔) 455 | (when (double-barred-char? sep) 456 | (line-of-interest) 457 | (readerr "expected not to find a cell boundary character" pos)))] 458 | [else 459 | (define allowed-chars 460 | (if (null? table-column-breaks) 461 | (list (get-one (not cell-wall-broken?) (car previous-map) #f #f) 462 | (get-one (not cell-wall-broken?) (car previous-map) #f #t)) 463 | (list (get-one (not cell-wall-broken?) (car previous-map) #f #f) 464 | (get-one (not cell-wall-broken?) (car previous-map) #f #t) 465 | (get-one (not cell-wall-broken?) (car previous-map) #t #f) 466 | (get-one (not cell-wall-broken?) (car previous-map) #t #t)))) 467 | (unless (member sep allowed-chars) 468 | (line-of-interest) 469 | (readerr/expected (filter values allowed-chars) pos))]) 470 | (cond 471 | [(null? table-column-breaks) 472 | (whitespace-to-end (+ pos 1)) 473 | (reverse (cons #t map))] 474 | [else 475 | (define next-cell-wall-broken? (not (member sep rt-chars))) 476 | (define edge-going-down? (and (member sep dn-chars) #t)) 477 | (define next-column (+ current-column 1)) 478 | (add-node next-column current-row) 479 | (when next-cell-wall-broken? 480 | (add-edge next-column current-row 481 | next-column (- current-row 1))) 482 | (unless edge-going-down? 483 | (add-edge next-column current-row 484 | (- next-column 1) current-row)) 485 | (loop (car table-column-breaks) 486 | (cdr table-column-breaks) 487 | (+ pos 1) 488 | next-cell-wall-broken? 489 | (make-a-guide pos) 490 | (cons edge-going-down? map) 491 | (cdr previous-map) 492 | next-column)])] 493 | [else 494 | (unless (< pos current-line-length) 495 | (line-of-interest) 496 | (readerr "line ended in the middle of a cell" pos)) 497 | (cond 498 | [cell-wall-broken? 499 | (when (double-barred-char? (string-ref current-line pos)) 500 | (line-of-interest) 501 | (readerr 502 | (format "expected not to find a cell boundary character (based on earlier ~a)" 503 | (guide-char cell-wall-guide)) 504 | pos 505 | #:guides (list cell-wall-guide)))] 506 | [else 507 | (unless (equal? (string-ref current-line pos) #\═) 508 | (line-of-interest) 509 | (readerr/expected '(#\═) pos #:guides (list cell-wall-guide)))]) 510 | (loop (- current-cell-size 1) 511 | table-column-breaks 512 | (+ pos 1) 513 | cell-wall-broken? 514 | cell-wall-guide 515 | map 516 | previous-map 517 | current-column)]))) 518 | 519 | (define (continue-line map previous-line-separator?) 520 | (let loop ([current-cell-size (car table-column-breaks)] 521 | [table-column-breaks (cdr table-column-breaks)] 522 | [map map] 523 | [pos (+ initial-space-count 1)] 524 | [column-number 0] 525 | [starting-a-new-cell? #t]) 526 | (cond 527 | [(zero? current-cell-size) 528 | (unless (< pos current-line-length) 529 | (line-of-interest) 530 | (readerr "line ended at the boundary of a cell, expected the edge of the cell" pos)) 531 | (cond 532 | [(car map) 533 | (unless (equal? (string-ref current-line pos) #\║) 534 | (line-of-interest) 535 | (readerr/expected '(#\║) pos))] 536 | [else 537 | (when (double-barred-char? (string-ref current-line pos)) 538 | (line-of-interest) 539 | (readerr "expected not to find a cell boundary character" pos))]) 540 | (cond 541 | [(null? table-column-breaks) 542 | (whitespace-to-end (+ pos 1))] 543 | [else 544 | (loop (car table-column-breaks) 545 | (cdr table-column-breaks) 546 | (cdr map) 547 | (+ pos 1) 548 | (+ column-number 1) 549 | #t)])] 550 | [else 551 | (unless (< pos current-line-length) 552 | (line-of-interest) 553 | (readerr "line ended in the middle of a cell" pos)) 554 | (when (double-barred-char? (string-ref current-line pos)) 555 | (line-of-interest) 556 | (readerr "expected not to find a cell boundary character" pos)) 557 | (when previous-line-separator? 558 | (when starting-a-new-cell? 559 | (set! position-of-first-cell 560 | (hash-set 561 | position-of-first-cell 562 | (list column-number current-row) 563 | (guide-srcloc (make-a-guide pos)))))) 564 | (loop (- current-cell-size 1) 565 | table-column-breaks 566 | map 567 | (+ pos 1) 568 | column-number 569 | #f)])) 570 | map) 571 | 572 | 573 | (define (finish-table map) 574 | (set! rows (cons (reverse pending-row) rows)) 575 | (let loop ([current-cell-size (car table-column-breaks)] 576 | [table-column-breaks (cdr table-column-breaks)] 577 | [map map] 578 | [pos (+ initial-space-count 1)]) 579 | (cond 580 | [(zero? current-cell-size) 581 | (unless (< pos current-line-length) 582 | (line-of-interest) 583 | (readerr "line ended in the middle of a cell" pos)) 584 | (define expected-char 585 | (cond 586 | [(null? table-column-breaks) #\╝] 587 | [(car map) #\╩] 588 | [else #\═])) 589 | (unless (equal? (string-ref current-line pos) expected-char) 590 | (line-of-interest) 591 | (readerr/expected (list expected-char) pos)) 592 | (cond 593 | [(null? table-column-breaks) 594 | #f] 595 | [else 596 | (loop (car table-column-breaks) 597 | (cdr table-column-breaks) 598 | (cdr map) 599 | (+ pos 1))])] 600 | [else 601 | (unless (< pos current-line-length) 602 | (line-of-interest) 603 | (readerr "line ended in the middle of a cell" pos)) 604 | (unless (equal? (string-ref current-line pos) #\═) 605 | (line-of-interest) 606 | (readerr/expected '(#\═) pos)) 607 | (loop (- current-cell-size 1) 608 | table-column-breaks 609 | map 610 | (+ pos 1))]))) 611 | 612 | (define (whitespace-to-end pos) 613 | (let loop ([pos pos]) 614 | (when (< pos current-line-length) 615 | (define c (string-ref current-line pos)) 616 | (cond 617 | [(equal? #\space c) 618 | (loop (+ pos 1))] 619 | [(equal? #\; c) 620 | (void)] 621 | [else 622 | (line-of-interest) 623 | (readerr "expected only whitespace outside of the table" pos)])))) 624 | 625 | (define (make-a-guide pos-in-line) 626 | (guide (string-ref current-line pos-in-line) 627 | (srcloc source current-line-number pos-in-line 628 | (+ current-line-start-position pos-in-line) 629 | 1))) 630 | 631 | (define (readerr/expected chars pos-in-line #:guides [guides '()]) 632 | (readerr (format "expected ~a~a~a" 633 | (if (null? (cdr chars)) 634 | "" 635 | "one of ") 636 | (chars->desc chars "or") 637 | (if (null? guides) 638 | "" 639 | (format " (based on earlier ~a)" 640 | (chars->desc (map guide-char guides) 641 | "and")))) 642 | pos-in-line 643 | #:guides guides)) 644 | 645 | (define (readerr msg pos-in-line [span 1] #:guides [guides '()]) 646 | (raise-read-error msg 647 | source 648 | current-line-number 649 | pos-in-line 650 | (+ current-line-start-position pos-in-line) 651 | span 652 | #:extra-srclocs (map guide-srcloc guides))) 653 | 654 | (let loop ([map (or last-left-map 655 | (begin 656 | (process-first-line) 657 | (map (λ (x) #t) table-column-breaks)))] 658 | [previous-line-separator? #t]) 659 | (define-values (next-map continue?) (process-a-line map previous-line-separator?)) 660 | (cond 661 | [continue? (loop next-map #f)] 662 | [next-map next-map] 663 | [else #f]))) 664 | 665 | ;; chars : non-empty-list-of-char -> string 666 | (define (chars->desc chars sep) 667 | (cond 668 | [(null? (cdr chars)) 669 | (format "~a" (car chars))] 670 | [else 671 | (define commas? (pair? (cddr chars))) 672 | (apply 673 | string-append 674 | (let loop ([chars chars] 675 | [first? #t]) 676 | (cond 677 | [(null? (cdr chars)) 678 | (list (format "~a~a ~a" 679 | (if first? "" " ") 680 | sep 681 | (car chars)))] 682 | [else 683 | (cons (format "~a~a~a" 684 | (if first? "" " ") 685 | (car chars) 686 | (if commas? "," "")) 687 | (loop (cdr chars) #f))])))])) 688 | 689 | (define (double-barred-char? c) (member c double-barred-chars)) 690 | 691 | (define (get-one lt? up? rt? dn?) 692 | (define (cmb a b) (if a b (not b))) 693 | (for/or ([c (in-list double-barred-chars)]) 694 | (and (cmb lt? (member c lt-chars)) 695 | (cmb up? (member c up-chars)) 696 | (cmb rt? (member c rt-chars)) 697 | (cmb dn? (member c dn-chars)) 698 | c))) 699 | -------------------------------------------------------------------------------- /2d-lib/private/readtable.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | #| 3 | 4 | ideas: 5 | - 2dcond 6 | - 2dmatch 7 | - literal tables in scribble layout? 8 | - something for graphics? 9 | 10 | example uses: 11 | - unifier 12 | - subtyping relation 13 | 14 | |# 15 | 16 | (require "read-util.rkt" 17 | racket/set 18 | ;syntax/rect 19 | "../dir-chars.rkt" 20 | racket/port) 21 | 22 | 23 | (provide make-2d-readtable 24 | 2d-readtable-dispatch-proc) 25 | 26 | (define (make-2d-readtable) 27 | (define previous-readtable (current-readtable)) 28 | (make-readtable 29 | previous-readtable 30 | #\2 31 | 'dispatch-macro 32 | (case-lambda 33 | [(char port) 34 | (define-values (line col pos) (port-next-location port)) 35 | 36 | ;; the "-2"s here are because the initial line and column 37 | ;; are supposed be at the beginning of the thing read, not 38 | ;; after the "#2" has been consumed. 39 | (2d-readtable-dispatch-proc char port #f line 40 | (and col (- col 2)) 41 | (and pos (- pos 2)) 42 | read/recursive previous-readtable)] 43 | [(char port source _line _col _pos) 44 | (2d-readtable-dispatch-proc char port source _line _col _pos 45 | (λ (a b c) (read-syntax/recursive source a b c)) 46 | previous-readtable)]))) 47 | 48 | (define (2d-readtable-dispatch-proc char port source _line _col _pos /recursive previous-readtable) 49 | (define next-char (peek-char port)) 50 | (cond 51 | [(equal? next-char #\d) 52 | (define chars-read 2) ;; account for the # and the 2 53 | (define (rc) 54 | (set! chars-read (+ chars-read 1)) 55 | (read-char port)) 56 | (rc) ;; get the #\d 57 | (define kwd-chars 58 | (let loop () 59 | (define c (rc)) 60 | (cond 61 | [(eof-object? c) 62 | (raise (make-exn:fail:read:eof 63 | "expected a newline to follow #2d" 64 | (current-continuation-marks) 65 | (list (srcloc source 66 | _line _col _pos 67 | (+ _pos chars-read)))))] 68 | [(equal? c #\newline) '()] 69 | [(equal? c #\return) 70 | (when (equal? #\newline (peek-char port)) 71 | (rc)) 72 | '()] 73 | [else (cons c (loop))]))) 74 | (define-values (post-2d-line post-2d-col post-2d-span) (port-next-location port)) 75 | (define-values (cell-connections 76 | lines 77 | table-column-breaks 78 | initial-space-count 79 | position-of-first-cell) 80 | (parse-2dcond port source _line _col _pos chars-read)) 81 | (define lhses (close-cell-graph cell-connections 82 | (length table-column-breaks) 83 | (vector-length lines))) 84 | (define scratch-string (make-string (for/sum ([ss (in-vector lines)]) 85 | (for/sum ([s (in-list ss)]) 86 | (string-length s))) 87 | #\space)) 88 | 89 | (define heights 90 | (for/list ([line (in-vector lines)]) 91 | (length line))) 92 | 93 | (define kwd-str (string-append "2d" (apply string kwd-chars))) 94 | (define kwd-port (open-input-string kwd-str)) 95 | (port-count-lines! kwd-port) 96 | (set-port-next-location! kwd-port _line (and _col (+ _col 1)) (and _pos (+ _pos 1))) 97 | (define kwd-stx (read-syntax source kwd-port)) 98 | 99 | (define line-width (+ initial-space-count 100 | (apply + table-column-breaks) 101 | (max 0 (- (length table-column-breaks) 1)))) 102 | 103 | (define (add-srclocs indicies) 104 | (for/list ([index (in-list indicies)]) 105 | (define srcloc (hash-ref position-of-first-cell index)) 106 | (datum->syntax #f 107 | index 108 | (vector (srcloc-source srcloc) 109 | #f ;; line 110 | #f ;; col 111 | (srcloc-position srcloc) 112 | 1)))) 113 | 114 | `(,kwd-stx 115 | 116 | ,table-column-breaks 117 | ,heights 118 | 119 | ,@(for/list ([set-of-indicies (in-list (sort (set->list lhses) compare/xy 120 | #:key smallest-representative))]) 121 | (fill-scratch-string set-of-indicies 122 | lines 123 | scratch-string 124 | table-column-breaks 125 | initial-space-count) 126 | (define scratch-port (open-input-string scratch-string)) 127 | (when post-2d-line (port-count-lines! scratch-port)) 128 | (set-port-next-location! scratch-port post-2d-line post-2d-col post-2d-span) 129 | `[,(add-srclocs (sort (set->list set-of-indicies) compare/xy)) 130 | ,@(read-subparts source scratch-port 131 | initial-space-count table-column-breaks heights set-of-indicies 132 | /recursive)]))] 133 | [else 134 | (/recursive 135 | (input-port-append #f (open-input-string "#2") port #:name (object-name port)) 136 | #f 137 | previous-readtable)])) 138 | 139 | 140 | (define (read-subparts source scratch-port 141 | initial-space-count table-column-breaks heights lhs 142 | /recursive) 143 | (with-handlers (#; 144 | [exn:fail:read? 145 | (λ (exn) 146 | (define constructor 147 | (cond 148 | [(exn:fail:read:eof? exn) exn:fail:read:eof/rects] 149 | [(exn:fail:read:non-char? exn) exn:fail:read:non-char/rects] 150 | [else exn:fail:read/rects])) 151 | (raise 152 | (constructor (exn-message exn) 153 | (exn-continuation-marks exn) 154 | (exn:fail:read-srclocs exn) 155 | (build-rectangles 156 | source 157 | initial-space-count table-column-breaks heights lhs))))]) 158 | (let loop () 159 | (define o (/recursive scratch-port #f (current-readtable))) 160 | (cond 161 | [(eof-object? o) '()] 162 | [else (cons o (loop))])))) 163 | 164 | #; 165 | (define (build-rectangles source table-column-breaks heights set-of-indicies) 166 | (for/list ([pr (in-set set-of-indicies)]) 167 | (define x (list-ref pr 0)) 168 | (define y (list-ref pr 1)) 169 | (srcloc-rect source 170 | ?-start-position 171 | (list-ref table-column-breaks x) 172 | (list-ref heights y)))) 173 | 174 | -------------------------------------------------------------------------------- /2d-lib/readtable.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "private/readtable.rkt" 4 | racket/contract) 5 | (provide 6 | (contract-out 7 | [2d-readtable-dispatch-proc 8 | (-> char? input-port? any/c 9 | (or/c exact-positive-integer? #f) 10 | (or/c exact-nonnegative-integer? #f) 11 | (or/c exact-positive-integer? #f) 12 | (-> input-port? any/c (or/c readtable? #f) any/c) 13 | (or/c #f readtable?) 14 | any/c)]) 15 | make-readtable) 16 | -------------------------------------------------------------------------------- /2d-lib/tabular.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | scribble/base 4 | scribble/core) 5 | (provide 2dtabular) 6 | (define-syntax (2dtabular stx) 7 | (syntax-case stx () 8 | [(_ cols rows cells ...) 9 | (let () 10 | (define row-count (length (syntax->list #'rows))) 11 | (define col-count (length (syntax->list #'cols))) 12 | (define table (make-hash)) 13 | (define the-sep #f) 14 | (define the-style #f) 15 | (define ignore-first-line? #f) 16 | (define has-keywords? #f) 17 | (for ([cell (in-list (syntax->list #'(cells ...)))]) 18 | (syntax-case cell () 19 | [[(coord ...) body ...] 20 | (let () 21 | (define coords 22 | (sort 23 | (for/list ([coord (in-list (syntax->list #'(coord ...)))]) 24 | (define lst (syntax->datum coord)) 25 | (cons (car lst) 26 | (cadr lst))) 27 | < 28 | #:key car)) 29 | (define bodies (syntax->list #'(body ...))) 30 | (unless (or (null? (cdr coords)) (apply = (map cdr coords))) 31 | (raise-syntax-error '2dtabular 32 | "cells may not span rows" 33 | stx 34 | #f 35 | bodies)) 36 | (define keyword-line? 37 | (and (= (+ (cdr (car coords)) 1) row-count) 38 | (= (length coords) col-count) 39 | (ormap (λ (x) (keyword? (syntax-e x))) bodies))) 40 | (when keyword-line? (set! has-keywords? #t)) 41 | (cond 42 | [keyword-line? 43 | ;; last row, spans the entire table, contains keywords 44 | ;; => treat as keyword arguments to tabular 45 | (let loop ([bodies bodies]) 46 | (syntax-case bodies () 47 | [(#:style style-arg . rest) 48 | (begin 49 | (set! the-style #'style-arg) 50 | (loop #'rest))] 51 | [(#:style) 52 | (raise-syntax-error '2dtabular 53 | "expected a style to follow the #:style keyword" 54 | stx 55 | (car bodies))] 56 | [(#:sep sep-arg . rest) 57 | (begin 58 | (set! the-sep #'sep-arg) 59 | (loop #'rest))] 60 | [(#:sep) 61 | (raise-syntax-error '2dtabular 62 | "expected a separator to follow the #:sep keyword" 63 | stx 64 | (car bodies))] 65 | [(#:ignore-first-row . rest) 66 | (begin (set! ignore-first-line? #t) 67 | (loop #'rest))] 68 | [() (void)] 69 | [(a . b) 70 | (cond 71 | [(special-comment? (syntax-e #'a)) 72 | (loop #'b)] 73 | [else 74 | (raise-syntax-error '2dtabular 75 | "expected either the keyword #:style #:sep or #:ignore-first-row" 76 | stx 77 | #'a)])]))] 78 | [else 79 | (define no-comment-bodies 80 | (for/list ([body (in-list bodies)] 81 | #:unless (special-comment? (syntax-e body))) 82 | (when (keyword? (syntax-e body)) 83 | (raise-syntax-error '2dtabular 84 | "unexpected keyword" 85 | stx 86 | body)) 87 | body)) 88 | (hash-set! table 89 | (car coords) 90 | #`(build-block #,@no-comment-bodies)) 91 | (for ([coord (in-list (cdr coords))]) 92 | (hash-set! table coord #''cont))]))])) 93 | #`(tabular #,@(if the-style #`(#:style #,the-style) #'()) 94 | #,@(if the-sep #`(#:sep #,the-sep) #'()) 95 | (list #,@(for/list ([y (in-range 96 | (if ignore-first-line? 1 0) 97 | (if has-keywords? 98 | (- row-count 1) 99 | row-count))]) 100 | #`(list #,@(for/list ([x (in-range col-count)]) 101 | (hash-ref table (cons x y))))))))])) 102 | 103 | (define (build-block . block-or-contents) 104 | (define (build-block pending) 105 | (paragraph (style #f '()) (reverse pending))) 106 | 107 | (define blocks 108 | (let loop ([args block-or-contents] 109 | [pending '()]) 110 | (cond 111 | [(null? args) 112 | (if (null? pending) 113 | '() 114 | (list (build-block pending)))] 115 | [else 116 | (define arg (car args)) 117 | (cond 118 | [(content? arg) 119 | (loop (cdr args) (cons arg pending))] 120 | [else 121 | (if (null? pending) 122 | (cons arg (loop (cdr args) '())) 123 | (list* (build-block pending) 124 | arg 125 | (loop (cdr args) '())))])]))) 126 | 127 | (nested-flow (style #f '()) blocks)) 128 | 129 | 130 | 131 | 132 | -------------------------------------------------------------------------------- /2d-test/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "2d") 4 | (define version "1.0") 5 | (define deps '("base" "2d-lib" "racket-index")) 6 | (define build-deps '("rackunit-lib" 7 | "option-contract-lib" 8 | "at-exp-lib" 9 | "gui-lib" 10 | "syntax-color-lib")) 11 | (define pkg-desc "tests for \"2d\"") 12 | (define pkg-authors '(robby)) 13 | 14 | (define license 15 | '(Apache-2.0 OR MIT)) 16 | -------------------------------------------------------------------------------- /2d-test/tests/cond-test.rkt: -------------------------------------------------------------------------------- 1 | #lang 2d racket/base 2 | (require 2d/cond 3 | rackunit) 4 | 5 | (define (basic a b c d) 6 | #2dcond 7 | ╔═══╦═══╦═══╗ 8 | ║ ║ a ║ b ║ 9 | ╠═══╬═══╬═══╣ 10 | ║ c ║ 1 ║ 2 ║ 11 | ╠═══╬═══╬═══╣ 12 | ║ d ║ 3 ║ 4 ║ 13 | ╚═══╩═══╩═══╝) 14 | 15 | (define ((matches reg) exn) (regexp-match? reg (exn-message exn))) 16 | 17 | (check-equal? (basic #t #t #t #t) 1) 18 | (check-equal? (basic #t #f #t #f) 1) 19 | (check-equal? (basic #f #t #t #t) 2) 20 | (check-equal? (basic #f #t #t #f) 2) 21 | (check-equal? (basic #t #t #f #t) 3) 22 | (check-equal? (basic #t #f #f #t) 3) 23 | (check-equal? (basic #f #t #f #t) 4) 24 | (check-exn (matches #rx"x-direction questions") 25 | (λ () (basic #f #f #f #f))) 26 | (check-exn (matches #rx"y-direction questions.*x coordinate 1") 27 | (λ () (basic #t #f #f #f))) 28 | (check-exn (matches #rx"y-direction questions.*x coordinate 2") 29 | (λ () (basic #f #t #f #f))) 30 | 31 | (define (bot-right-cell a b c d) 32 | #2dcond 33 | ╔═══╦═══╦═══╗ 34 | ║ ║ a ║ b ║ 35 | ╠═══╬═══╩═══╣ 36 | ║ c ║ 1 ║ 37 | ╠═══╣ ╔═══╣ 38 | ║ d ║ ║ 2 ║ 39 | ╚═══╩═══╩═══╝) 40 | 41 | (check-equal? (bot-right-cell #t #t #t #t) 1) 42 | (check-equal? (bot-right-cell #t #f #t #f) 1) 43 | (check-equal? (bot-right-cell #f #t #t #t) 1) 44 | (check-equal? (bot-right-cell #f #t #t #f) 1) 45 | (check-equal? (bot-right-cell #t #t #f #t) 1) 46 | (check-equal? (bot-right-cell #t #f #f #t) 1) 47 | (check-equal? (bot-right-cell #f #t #f #t) 2) 48 | 49 | (define (top-left-cell a b c d) 50 | #2dcond 51 | ╔═══╦═══╦═══╗ 52 | ║ ║ a ║ b ║ 53 | ╠═══╬═══╬═══╣ 54 | ║ c ║ 1 ║ ║ 55 | ╠═══╬═══╝ ║ 56 | ║ d ║ 2 ║ 57 | ╚═══╩═══════╝) 58 | 59 | (check-equal? (top-left-cell #t #t #t #t) 1) 60 | (check-equal? (top-left-cell #t #f #t #f) 1) 61 | (check-equal? (top-left-cell #f #t #t #t) 2) 62 | (check-equal? (top-left-cell #f #t #t #f) 2) 63 | (check-equal? (top-left-cell #t #t #f #t) 2) 64 | (check-equal? (top-left-cell #t #f #f #t) 2) 65 | (check-equal? (top-left-cell #f #t #f #t) 2) 66 | 67 | (let ([sp (open-output-string)]) 68 | (define (f x) (printf "~a\n" x) #f) 69 | (parameterize ([current-output-port sp]) 70 | #2dcond 71 | ╔═════╦═══════╦═══════╦════╗ 72 | ║ ║ (f 1) ║ (f 2) ║ #t ║ 73 | ╠═════╬═══════╩═══════╩════╣ 74 | ║(f 3)║ ║ 75 | ╠═════╣ ║ 76 | ║(f 4)║ 222 ║ 77 | ╠═════╣ ║ 78 | ║ #t ║ ║ 79 | ╚═════╩════════════════════╝) 80 | (check-equal? (get-output-string sp) 81 | "1\n2\n3\n4\n")) 82 | 83 | 84 | (define (try-else a b c) 85 | #2dcond 86 | ╔════╦════╦════╗ 87 | ║ ║ a ║else║ 88 | ╠════╬════╬════╣ 89 | ║ b ║ 1 ║ 2 ║ 90 | ╠════╬════╬════╣ 91 | ║ c ║ 3 ║ 4 ║ 92 | ╠════╬════╬════╣ 93 | ║else║ 5 ║ 6 ║ 94 | ╚════╩════╩════╝) 95 | 96 | (require rackunit) 97 | (check-equal? (try-else #t #t #f) 1) 98 | (check-equal? (try-else #f #t #f) 2) 99 | (check-equal? (try-else #t #f #f) 5) 100 | (check-equal? (try-else #f #f #f) 6) 101 | 102 | 103 | 104 | 105 | -------------------------------------------------------------------------------- /2d-test/tests/docs-complete.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit/docs-complete) 3 | (check-docs '2d/cond) 4 | (check-docs '2d/dir-chars) 5 | (check-docs '2d/lexer) 6 | (check-docs '2d/match) 7 | (check-docs '2d/readtable) 8 | (check-docs '2d/tabular) 9 | -------------------------------------------------------------------------------- /2d-test/tests/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define test-responsibles '((all robby))) 4 | -------------------------------------------------------------------------------- /2d-test/tests/lexer-stress-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (require framework/private/color-local-member-name 4 | syntax-color/racket-lexer 5 | 2d/lexer 6 | framework) 7 | 8 | (define f (new frame% [label ""] [width 400] [height 600])) 9 | (define t (new (class racket:text% 10 | (define/override (tokenizing-give-up-early) 11 | (when (zero? (random 2)) 12 | (do-something)) 13 | #t) 14 | (super-new)))) 15 | (define ec (new editor-canvas% [parent f] [editor t])) 16 | 17 | (define count 0) 18 | 19 | (define (do-something) 20 | (queue-callback (λ () 21 | (set! count (+ count 1)) 22 | (cond 23 | [(< count 100) 24 | (cond 25 | [(send t find-string "-" 'forward 0) 26 | => 27 | (λ (x) 28 | (send t delete x (+ x 1)))] 29 | [else 30 | ;; these two numbers are dependent 31 | ;; on the string constant below 32 | (define n (+ 36 (random 448))) 33 | (define howmany (+ 1 (random 2))) 34 | (for ([x (in-range howmany)]) 35 | (send t insert "-" n n))])] 36 | [else 37 | (send tmr stop) 38 | (send f show #f)])))) 39 | 40 | (define tmr (new timer% [notify-callback do-something] [interval 100])) 41 | 42 | (send f show #t) 43 | 44 | (send t insert 45 | #<<--- 46 | #lang 2d racket/base 47 | 48 | #2dx 49 | ╔═══╦═══╦═══╦═══╗ 50 | ║ 1 ║ 2 ║ 3 ║ 4 ║ 51 | ╠═══╬═══╩═══╩═══╣ 52 | ║ 5 ║("abcdef") ║ 53 | ╠═══╣(|zz zzz|) ║ 54 | ║ 6 ║(31415926) ║ 55 | ╠═══╬═══╦═══╦═══╣ 56 | ║ 7 ║ 8 ║ 9 ║ 0 ║ 57 | ╠═══╬═══╬═══╬═══╣ 58 | ║ A ║ B ║ C ║ D ║ 59 | ╠═══╬═══╩═══╩═══╣ 60 | ║ E ║("ghijkl") ║ 61 | ╠═══╣(|xx xxx|) ║ 62 | ║ F ║(27182818) ║ 63 | ╠═══╬═══╦═══╦═══╣ 64 | ║ G ║ H ║ I ║ J ║ 65 | ╠═══╬═══╬═══╬═══╣ 66 | ║ K ║ L ║ M ║ N ║ 67 | ╠═══╬═══╩═══╩═══╣ 68 | ║ O ║("mnopqs") ║ 69 | ╠═══╣(|yy yyy|) ║ 70 | ║ P ║(whatever) ║ 71 | ╠═══╬═══╦═══╦═══╣ 72 | ║ Q ║ R ║ S ║ T ║ 73 | ╚═══╩═══╩═══╩═══╝ 74 | 75 | --- 76 | ) 77 | 78 | -------------------------------------------------------------------------------- /2d-test/tests/lexer-test.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp racket/base 2 | (require rackunit 3 | syntax-color/racket-lexer 4 | syntax-color/scribble-lexer 5 | syntax-color/lexer-contract 6 | racket/contract/option 7 | 2d/private/lexer 8 | racket/port) 9 | 10 | (check-equal? (cropped-regions 0 10 '()) '()) 11 | (check-equal? (cropped-regions 0 10 '((0 . 10))) '((0 . 10))) 12 | (check-equal? (cropped-regions 0 10 '((0 . 5) (7 . 10))) '((7 . 10) (0 . 5))) 13 | (check-equal? (cropped-regions 0 10 '((-1 . 4))) '((0 . 4))) 14 | (check-equal? (cropped-regions 0 10 '((-4 . -3))) '()) 15 | (check-equal? (cropped-regions 0 10 '((20 . 30))) '()) 16 | (check-equal? (cropped-regions 0 10 '((1 . 4) (5 . 20))) '((5 . 10) (1 . 4))) 17 | (check-equal? (cropped-regions 0 10 '((-5 . 10))) '((0 . 10))) 18 | (check-equal? (cropped-regions 13 37 '((11 . 13))) '()) 19 | 20 | (define (run-lexer #:sub-lexer [sub-lexer/no-ex racket-lexer] . strs/specials) 21 | (define sub-lexer (if (has-option? sub-lexer/no-ex) 22 | (exercise-option sub-lexer/no-ex) 23 | sub-lexer/no-ex)) 24 | (define-values (in out) (make-pipe-with-specials)) 25 | (thread 26 | (λ () 27 | (let loop ([s strs/specials]) 28 | (cond 29 | [(list? s) 30 | (for ([s (in-list strs/specials)]) 31 | (loop s))] 32 | [(string? s) (display s out)] 33 | [else (write-special s out)])) 34 | (close-output-port out))) 35 | (port-count-lines! in) 36 | (define the-lexer (exercise-option (2d-lexer sub-lexer))) 37 | (let loop ([mode #f]) 38 | (define-values (val tok paren start end backup new-mode) 39 | (the-lexer in 0 mode)) 40 | (cons (list val tok paren start end backup) 41 | (cond 42 | [(equal? tok 'eof) '()] 43 | [else (loop (if (dont-stop? new-mode) 44 | (dont-stop-val new-mode) 45 | new-mode))])))) 46 | 47 | (check-equal? 48 | (run-lexer "1234\n#2d\n") 49 | `(("1234" constant #f 1 5 0) 50 | ("\n" white-space #f 5 6 0) 51 | ("#2d\n" error #f 6 10 0) 52 | (,eof eof #f #f #f 0))) 53 | 54 | (check-equal? 55 | (run-lexer "#2dsomething") 56 | `(("#2dsomething" error #f 1 13 0) 57 | (,eof eof #f #f #f 0))) 58 | 59 | (check-equal? 60 | (run-lexer "#2dsomething\n") 61 | `(("#2dsomething\n" error #f 1 14 0) 62 | (,eof eof #f #f #f 0))) 63 | 64 | (check-equal? 65 | (run-lexer "#2dsomething\n╔═══╗\n║ ║") 66 | `(("#2dsomething\n╔═══╗\n║ ║" error #f 1 25 0) 67 | (,eof eof #f #f #f 0))) 68 | 69 | (check-equal? 70 | (run-lexer "#2dsomething\n \n") 71 | `(("#2dsomething" hash-colon-keyword #f 1 13 0) 72 | ("\n" white-space #f 13 14 13) 73 | (" \n" error #f 14 17 14) 74 | (,eof eof #f #f #f 0))) 75 | 76 | (check-equal? 77 | @run-lexer{#2d 78 | ╔══╦═══╗ 79 | ║+ ║"a"║ 80 | ╠══╬═══╣ 81 | ║34║"b"║ 82 | ╚══╩═══╝} 83 | `(("#2d" hash-colon-keyword #f 1 4 0) 84 | ("\n" white-space #f 4 5 4) 85 | ("╔══╦═══╗" parenthesis #f 5 13 5) 86 | (" " white-space #f 13 14 13) 87 | ("║" parenthesis #f 14 15 14) 88 | ("+" symbol #f 15 16 15) 89 | (" " white-space #f 16 17 16) 90 | ("║" parenthesis #f 17 18 17) 91 | ("\"a\"" string #f 18 21 18) 92 | ("║" parenthesis #f 21 22 21) 93 | (" " white-space #f 22 23 22) 94 | ("╠══╬═══╣" parenthesis #f 23 31 23) 95 | (" " white-space #f 31 32 31) 96 | ("║" parenthesis #f 32 33 32) 97 | ("34" constant #f 33 35 33) 98 | ("║" parenthesis #f 35 36 35) 99 | ("\"b\"" string #f 36 39 36) 100 | ("║" parenthesis #f 39 40 39) 101 | (" " white-space #f 40 41 40) 102 | ("╚══╩═══╝" parenthesis #f 41 49 41) 103 | (,eof eof #f #f #f 0))) 104 | 105 | (check-equal? 106 | @run-lexer["#2d\r\n"]{╔══╦═══╗ 107 | ║+ ║"a"║ 108 | ╠══╬═══╣ 109 | ║34║"b"║ 110 | ╚══╩═══╝} 111 | `(("#2d" hash-colon-keyword #f 1 4 0) 112 | ("\r\n" white-space #f 4 5 4) 113 | ("╔══╦═══╗" parenthesis #f 5 13 5) 114 | (" " white-space #f 13 14 13) 115 | ("║" parenthesis #f 14 15 14) 116 | ("+" symbol #f 15 16 15) 117 | (" " white-space #f 16 17 16) 118 | ("║" parenthesis #f 17 18 17) 119 | ("\"a\"" string #f 18 21 18) 120 | ("║" parenthesis #f 21 22 21) 121 | (" " white-space #f 22 23 22) 122 | ("╠══╬═══╣" parenthesis #f 23 31 23) 123 | (" " white-space #f 31 32 31) 124 | ("║" parenthesis #f 32 33 32) 125 | ("34" constant #f 33 35 33) 126 | ("║" parenthesis #f 35 36 35) 127 | ("\"b\"" string #f 36 39 36) 128 | ("║" parenthesis #f 39 40 39) 129 | (" " white-space #f 40 41 40) 130 | ("╚══╩═══╝" parenthesis #f 41 49 41) 131 | (,eof eof #f #f #f 0))) 132 | 133 | (printf "skipping the \\r\\n test: see the cracks-filled-in-tokens definition for where the bug lies\n") 134 | #; 135 | (check-equal? 136 | (run-lexer "#2d\r\n" 137 | "╔══╦═══╗\r\n" 138 | "║+ ║abc║\r\n" 139 | "╠══╬═══╣\r\n" 140 | "║34║def║\r\n" 141 | "╚══╩═══╝\r\n") 142 | `(("#2d" hash-colon-keyword #f 1 4 0) 143 | ("\r\n" white-space #f 4 5 4) 144 | ("╔══╦═══╗" parenthesis #f 5 13 5) 145 | (" " white-space #f 13 14 13) 146 | ("║" parenthesis #f 14 15 14) 147 | ("+" symbol #f 15 16 15) 148 | (" " white-space #f 16 17 16) 149 | ("║" parenthesis #f 17 18 17) 150 | ("\"a\"" string #f 18 21 18) 151 | ("║" parenthesis #f 21 22 21) 152 | (" " white-space #f 22 23 22) 153 | ("╠══╬═══╣" parenthesis #f 23 31 23) 154 | (" " white-space #f 31 32 31) 155 | ("║" parenthesis #f 32 33 32) 156 | ("34" constant #f 33 35 33) 157 | ("║" parenthesis #f 35 36 35) 158 | ("\"b\"" string #f 36 39 36) 159 | ("║" parenthesis #f 39 40 39) 160 | (" " white-space #f 40 41 40) 161 | ("╚══╩═══╝" parenthesis #f 41 49 41) 162 | (,eof eof #f #f #f 0))) 163 | 164 | ;; test tokens that cross lines (and thus need cropping) 165 | (check-equal? 166 | @run-lexer{#2d 167 | ╔══╦═══╗ 168 | ║+ ║"a ║ 169 | ║+ ║ a"║ 170 | ╠══╬═══╣ 171 | ║34║"b"║ 172 | ╚══╩═══╝} 173 | `(("#2d" hash-colon-keyword #f 1 4 0) 174 | ("\n" white-space #f 4 5 4) 175 | ("╔══╦═══╗" parenthesis #f 5 13 5) 176 | (" " white-space #f 13 14 13) 177 | ("║" parenthesis #f 14 15 14) 178 | ("+" symbol #f 15 16 15) 179 | (" " white-space #f 16 17 16) 180 | ("║" parenthesis #f 17 18 17) 181 | ("\"a " string #f 18 21 18) 182 | ("║" parenthesis #f 21 22 21) 183 | (" " white-space #f 22 23 22) 184 | ("║" parenthesis #f 23 24 23) 185 | ("+" symbol #f 24 25 24) 186 | (" " white-space #f 25 26 25) 187 | ("║" parenthesis #f 26 27 26) 188 | (" a\"" string #f 27 30 27) 189 | ("║" parenthesis #f 30 31 30) 190 | (" " white-space #f 31 32 31) 191 | ("╠══╬═══╣" parenthesis #f 32 40 32) 192 | (" " white-space #f 40 41 40) 193 | ("║" parenthesis #f 41 42 41) 194 | ("34" constant #f 42 44 42) 195 | ("║" parenthesis #f 44 45 44) 196 | ("\"b\"" string #f 45 48 45) 197 | ("║" parenthesis #f 48 49 48) 198 | (" " white-space #f 49 50 49) 199 | ("╚══╩═══╝" parenthesis #f 50 58 50) 200 | (,eof eof #f #f #f 0))) 201 | 202 | (check-equal? 203 | @run-lexer{#2d 204 | ╔══╦═══╗ 205 | ║+ ║ "a"║ 206 | ╠══╬═══╣ 207 | ║34║"b"║ 208 | ╚══╩═══╝} 209 | `(("#2d" hash-colon-keyword #f 1 4 0) 210 | ("\n" white-space #f 4 5 4) 211 | ("╔══╦═══╗\n║+ ║ \"a" no-color #f 5 21 5) 212 | ("\"║\n╠══╬═══╣\n║34║\"b\"║\n╚══╩═══╝" error #f 21 50 21) 213 | (,eof eof #f #f #f 0))) 214 | 215 | (check-equal? 216 | @run-lexer["#2d\r\n"]{╔══╦═══╗ 217 | ║+ ║ "a"║ 218 | ╠══╬═══╣ 219 | ║34║"b"║ 220 | ╚══╩═══╝} 221 | `(("#2d" hash-colon-keyword #f 1 4 0) 222 | ("\r\n" white-space #f 4 5 4) 223 | ("╔══╦═══╗\n║+ ║ \"a" no-color #f 5 21 5) 224 | ("\"║\n╠══╬═══╣\n║34║\"b\"║\n╚══╩═══╝" error #f 21 50 21) 225 | (,eof eof #f #f #f 0))) 226 | 227 | (check-equal? 228 | (run-lexer " #2d\n" 229 | " ╔═╦═╗\n" 230 | " ║1║2║\n" 231 | " ╠═╬═╣\n" 232 | " ║3║4║\n" 233 | " ╚═╩═╝\n") 234 | `((" " white-space #f 1 4 0) 235 | ("#2d" hash-colon-keyword #f 4 7 0) 236 | ("\n" white-space #f 7 8 7) 237 | (" " white-space #f 8 11 8) 238 | ("╔═╦═╗" parenthesis #f 11 16 11) 239 | (" " white-space #f 16 20 16) 240 | ("║" parenthesis #f 20 21 20) 241 | ("1" constant #f 21 22 21) 242 | ("║" parenthesis #f 22 23 22) 243 | ("2" constant #f 23 24 23) 244 | ("║" parenthesis #f 24 25 24) 245 | (" " white-space #f 25 29 25) 246 | ("╠═╬═╣" parenthesis #f 29 34 29) 247 | (" " white-space #f 34 38 34) 248 | ("║" parenthesis #f 38 39 38) 249 | ("3" constant #f 39 40 39) 250 | ("║" parenthesis #f 40 41 40) 251 | ("4" constant #f 41 42 41) 252 | ("║" parenthesis #f 42 43 42) 253 | (" " white-space #f 43 47 43) ("╚═╩═╝" parenthesis #f 47 52 47) 254 | ("\n" white-space #f 52 53 0) 255 | (,eof eof #f #f #f 0))) 256 | 257 | (define-values (dont-care dont-care?) 258 | (let () 259 | (struct dont-care ()) 260 | (values (dont-care) dont-care?))) 261 | 262 | (define (equal?/dont-care x y) 263 | (let loop ([x x][y y]) 264 | (cond 265 | [(or (dont-care? x) (dont-care? y)) 266 | #t] 267 | [(and (pair? x) (pair? y)) 268 | (and (loop (car x) (car y)) 269 | (loop (cdr x) (cdr y)))] 270 | [else (equal? x y)]))) 271 | 272 | (check-pred 273 | (λ (x) 274 | (equal?/dont-care 275 | x 276 | `(("#2d" hash-colon-keyword #f 1 4 0) 277 | ("\n" white-space #f 4 5 4) 278 | ("╔═════╦═══════╗" parenthesis #f 5 20 5) 279 | (" " white-space #f 20 21 20) 280 | ("║" parenthesis #f 21 22 21) 281 | ("@" parenthesis #f 22 23 22) 282 | ("f" symbol #f 23 24 23) 283 | ("{" parenthesis |{| 24 25 24) 284 | (,dont-care text #f 25 26 25) 285 | ("}" parenthesis |}| 26 27 26) 286 | ("║" parenthesis #f 27 28 27) 287 | (" " white-space #f 28 29 28) 288 | ("@" parenthesis #f 29 30 29) 289 | ("g" symbol #f 30 31 30) 290 | ("{" parenthesis |{| 31 32 31) 291 | (,dont-care text #f 32 33 32) 292 | ("}" parenthesis |}| 33 34 33) 293 | (" " white-space #f 34 35 34) 294 | ("║" parenthesis #f 35 36 35) 295 | (" " white-space #f 36 37 36) 296 | ("╠═════╬═══════╣" parenthesis #f 37 52 37) 297 | (" " white-space #f 52 53 52) 298 | ("║" parenthesis #f 53 54 53) 299 | ("@" parenthesis #f 54 55 54) 300 | ("h" symbol #f 55 56 55) 301 | ("{" parenthesis |{| 56 57 56) 302 | (,dont-care text #f 57 58 57) 303 | ("}" parenthesis |}| 58 59 58) 304 | ("║" parenthesis #f 59 60 59) 305 | (" " white-space #f 60 61 60) 306 | ("@" parenthesis #f 61 62 61) 307 | ("i" symbol #f 62 63 62) 308 | ("{" parenthesis |{| 63 64 63) 309 | (,dont-care text #f 64 65 64) 310 | ("}" parenthesis |}| 65 66 65) 311 | (" " white-space #f 66 67 66) 312 | ("║" parenthesis #f 67 68 67) 313 | (" " white-space #f 68 69 68) 314 | ("╚═════╩═══════╝" parenthesis #f 69 84 69) 315 | ("\n" white-space #f 84 85 0) 316 | (,eof eof #f 85 85 0)))) 317 | (run-lexer #:sub-lexer scribble-lexer 318 | "#2d\n" 319 | "╔═════╦═══════╗\n" 320 | "║@f{x}║ @g{y} ║\n" 321 | "╠═════╬═══════╣\n" 322 | "║@h{z}║ @i{w} ║\n" 323 | "╚═════╩═══════╝\n")) 324 | 325 | (check-equal? 326 | (run-lexer "#2" 'not-a-char) 327 | `(("#2" error #f 1 3 0) 328 | ("" no-color #f 3 4 0) 329 | (,eof eof #f #f #f 0))) 330 | 331 | (check-equal? 332 | (run-lexer "#2d\n" 'not-a-char) 333 | `(("#2d" hash-colon-keyword #f 1 4 0) 334 | ("\n" white-space #f 4 5 4) 335 | (" " error #f 5 6 5) 336 | (,eof eof #f #f #f 0))) 337 | 338 | (check-equal? 339 | (run-lexer "#2d\n╔" 'not-a-char) 340 | `(("#2d" hash-colon-keyword #f 1 4 0) 341 | ("\n" white-space #f 4 5 4) 342 | ("╔" no-color #f 5 6 5) 343 | (" " error #f 6 7 6) 344 | (,eof eof #f #f #f 0))) 345 | 346 | 347 | (check-equal? 348 | (run-lexer "#2dsomething\n" 349 | "╔═══╗\n" 350 | "║ " 'special " ║\n" 351 | "╚═══╝") 352 | `(("#2dsomething" hash-colon-keyword #f 1 13 0) 353 | ("\n" white-space #f 13 14 13) 354 | ("╔═══╗\n║ " no-color #f 14 22 14) 355 | (" ║\n╚═══╝" error #f 22 31 22) 356 | (,eof eof #f #f #f 0))) 357 | 358 | (check-equal? 359 | (run-lexer "#2dsomething\n" 360 | "╔═══╗\n" 361 | 'special 362 | " ║\n" 363 | "╚═══╝") 364 | `(("#2dsomething" hash-colon-keyword #f 1 13 0) 365 | ("\n" white-space #f 13 14 13) 366 | ("╔═══╗\n" no-color #f 14 20 14) 367 | (" ║\n╚═══╝" error #f 20 31 20) 368 | (,eof eof #f #f #f 0))) 369 | 370 | (check-equal? 371 | (run-lexer "#2dwhatever\n" 372 | "╔════╦════╗\n" 373 | "║123;║5678║\n" 374 | "╚════╩════╝\n") 375 | `(("#2dwhatever" hash-colon-keyword #f 1 12 0) 376 | ("\n" white-space #f 12 13 12) 377 | ("╔════╦════╗" parenthesis #f 13 24 13) 378 | (" " white-space #f 24 25 24) 379 | ("║" parenthesis #f 25 26 25) 380 | ("123" constant #f 26 29 26) 381 | (" " comment #f 29 30 29) 382 | ("║" parenthesis #f 30 31 30) 383 | ("5678" constant #f 31 35 31) 384 | ("║" parenthesis #f 35 36 35) 385 | (" " white-space #f 36 37 36) 386 | ("╚════╩════╝" parenthesis #f 37 48 37) 387 | ("\n" white-space #f 48 49 0) 388 | (,eof eof #f #f #f 0))) 389 | 390 | -------------------------------------------------------------------------------- /2d-test/tests/match-test.rkt: -------------------------------------------------------------------------------- 1 | #lang 2d racket 2 | (require 2d/match 3 | rackunit) 4 | 5 | (check-equal? 6 | #2dmatch 7 | ╔═══════╦══════╦══════════╗ 8 | ║ 1 ║ 'x ║ x ║ 9 | ║ 2 ║ ║ ║ 10 | ╠═══════╬══════╬══════════╣ 11 | ║ y ║ #f ║(list x y)║ 12 | ╚═══════╩══════╩══════════╝ 13 | (list 1 2)) 14 | 15 | (define (≤ t1 t2) 16 | #2dmatch 17 | ╔══════════╦══════╦═══════╦══════════╦═════════════════╗ 18 | ║ t2 ║ 'Int ║ 'Real ║ 'Complex ║ `(-> ,t2d ║ 19 | ║ t1 ║ ║ ║ ║ ,t2r) ║ 20 | ╠══════════╬══════╩═══════╩══════════╬═════════════════╣ 21 | ║ 'Int ║ ║ ║ 22 | ╠══════════╬══════╗ #t ║ ║ 23 | ║ 'Real ║ ║ ║ #f ║ 24 | ╠══════════╣ ╚═══════╗ ║ ║ 25 | ║'Complex ║ ║ ║ ║ 26 | ╠══════════╣ ╚══════════╬═════════════════╣ 27 | ║`(-> ,t1d ║ #f ║(and (≤ t2d t1d) ║ 28 | ║ ,t1r)║ ║ (≤ t1r t2r))║ 29 | ╚══════════╩═════════════════════════╩═════════════════╝) 30 | 31 | (check-equal? (≤ 'Int 'Int) #t) 32 | (check-equal? (≤ 'Int 'Real) #t) 33 | (check-equal? (≤ 'Real 'Int) #f) 34 | (check-equal? (≤ 'Complex 'Complex) #t) 35 | (check-equal? (≤ 'Complex 'Int) #f) 36 | (check-equal? (≤ '(-> Real Int) '(-> Int Real)) #t) 37 | (check-equal? (≤ '(-> Int Complex) '(-> Int Real)) #f) 38 | 39 | (check-equal? 40 | #2dmatch 41 | ╔════════╦═══╗ 42 | ║ 3 ║ x ║ 43 | ║ 1 ║ ║ 44 | ╠════════╬═══╣ 45 | ║ 2 ║ ║ 46 | ╠════════╣ x ║ 47 | ║ 1 ║ ║ 48 | ╚════════╩═══╝ 49 | 3) 50 | 51 | (check-equal? 52 | #2dmatch 53 | ╔════════╦═══╗ 54 | ║ 3 ║ x ║ 55 | ║ 1 ║ ║ 56 | ╠════════╬═══╣ 57 | ║ z ║ ║ 58 | ╠════════╣ x ║ 59 | ║ q ║ ║ 60 | ╚════════╩═══╝ 61 | 3) 62 | 63 | (check-equal? 64 | #2dmatch 65 | ╔════════╦═══════╗ 66 | ║ 3 ║ x ║ 67 | ║ 1 ║ ║ 68 | ╠════════╬═══════╣ 69 | ║ y ║ ║ 70 | ╠════════╣(+ x y)║ 71 | ║ y ║ ║ 72 | ╚════════╩═══════╝ 73 | 4) 74 | 75 | (check-equal? ; test that leftmost scrutinee is column 76 | #2dmatch 77 | ╔══════╦═══╦═══╗ 78 | ║ 1 3 ║ 3 ║ 4 ║ 79 | ╠══════╬═══╬═══╣ 80 | ║ 1 ║'a ║'b ║ 81 | ╠══════╬═══╬═══╣ 82 | ║ 2 ║'c ║'d ║ 83 | ╚══════╩═══╩═══╝ 84 | 'a) 85 | 86 | (check-equal? ; test that bottommost scrutinee is column 87 | #2dmatch 88 | ╔═══╦═══╦═══╗ 89 | ║ 3 ║ 3 ║ 4 ║ 90 | ║ 1 ║ ║ ║ 91 | ╠═══╬═══╬═══╣ 92 | ║ 1 ║'a ║'b ║ 93 | ╠═══╬═══╬═══╣ 94 | ║ 2 ║'c ║'d ║ 95 | ╚═══╩═══╩═══╝ 96 | 'a) 97 | 98 | (check-equal? 99 | #2dmatch 100 | ╔══════╦═══╦═══╗ 101 | ║ 3 ║ 3 ║ 4 ║ 102 | ║ 1 ║ ║ ║ 103 | ╠══════╬═══╬═══╣ 104 | ║ 1 ║'a ║'b ║ 105 | ╠══════╬═══╬═══╣ 106 | ║ 2 ║'c ║'d ║ 107 | ╚══════╩═══╩═══╝ 108 | 'a) 109 | 110 | (check-equal? 111 | #2dmatch 112 | ╔══════╦═══╦═══╗ 113 | ║ 1 ║ 3 ║ 4 ║ 114 | ║ 3 ║ ║ ║ 115 | ╠══════╬═══╬═══╣ 116 | ║ 1 ║'a ║'b ║ 117 | ╠══════╬═══╬═══╣ 118 | ║ 2 ║'c ║'d ║ 119 | ╚══════╩═══╩═══╝ 120 | 'a) 121 | -------------------------------------------------------------------------------- /2d-test/tests/readtable-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | 2d/private/read-util 5 | 2d/private/readtable 6 | racket/set) 7 | 8 | (define touched-lines-table (make-hash)) 9 | 10 | (check-equal? (chars->desc '(#\a) "or") 11 | "a") 12 | (check-equal? (chars->desc '(#\a #\b) "or") 13 | "a or b") 14 | (check-equal? (chars->desc '(#\a #\b #\c) "or") 15 | "a, b, or c") 16 | (check-equal? (chars->desc '(#\a #\b #\c #\d) "or") 17 | "a, b, c, or d") 18 | (check-equal? (chars->desc '(#\a #\b #\c #\d #\e) "or") 19 | "a, b, c, d, or e") 20 | 21 | (check-equal? (read (open-input-string "#2(x)")) 22 | (parameterize ([current-readtable (make-2d-readtable)]) 23 | (read (open-input-string "#2(x)")))) 24 | (check-equal? (with-handlers ((exn:fail? exn-message)) 25 | (read (open-input-string "#2x(x)"))) 26 | (with-handlers ((exn:fail? exn-message)) 27 | (parameterize ([current-readtable (make-2d-readtable)]) 28 | (read (open-input-string "#2x(x)"))))) 29 | (check-true (syntax? (read-syntax 'hi (open-input-string "#2(x)")))) 30 | (check-equal? (read (open-input-string "#2(x)")) 31 | (parameterize ([current-readtable (make-2d-readtable)]) 32 | (syntax->datum (read-syntax 'hi (open-input-string "#2(x)"))))) 33 | 34 | (parameterize ([current-readtable (make-2d-readtable)]) 35 | (define sp (open-input-string 36 | (string-append "#2d\n" 37 | "╔══╦══╗\n" 38 | "║1 ║2 ║\n" 39 | "╠══╬══╣\n" 40 | "║4 ║3 ║\n" 41 | "╚══╩══╝\n"))) 42 | (define wp 43 | (make-input-port 'name sp sp void #f #f 44 | (λ () (values #f #f #f)) 45 | void)) 46 | (port-count-lines! wp) 47 | ;; make sure that if there is no source location information, 48 | ;; we still get some result back. 49 | (check-true (pair? (read wp)))) 50 | 51 | (parameterize ([current-readtable (make-2d-readtable)]) 52 | (define sp (open-input-string 53 | (string-append "#2d\n" 54 | "╔══╦══╗\n" 55 | "║1 ║2 ║\n" 56 | "╠══╬══╣\n" 57 | "║4 ║3 ║\n" 58 | "╚══╩══╝\n"))) 59 | (port-count-lines! sp) 60 | ;; make sure that if there is no source location information, 61 | ;; we still get some result back. 62 | (define stx (read-syntax "the source" sp)) 63 | (define initial-keyword (car (syntax-e stx))) 64 | (check-not-false (syntax-source initial-keyword)) 65 | (check-not-false (syntax-line initial-keyword)) 66 | (check-not-false (syntax-column initial-keyword)) 67 | (check-not-false (syntax-position initial-keyword)) 68 | (check-not-false (syntax-span initial-keyword)) 69 | (check-not-false (syntax-original? initial-keyword)) 70 | (check-not-equal? (syntax-position stx) 71 | (syntax-position initial-keyword))) 72 | 73 | (define (get-err-locs inputs) 74 | (with-handlers ([exn:fail:read? exn:fail:read-srclocs]) 75 | (define p (open-input-string (apply string-append inputs))) 76 | (port-count-lines! p) 77 | (parameterize ([current-readtable (make-2d-readtable)]) 78 | (read-syntax #f p)) 79 | #f)) 80 | 81 | (define (get-something inputs i) 82 | (define p (open-input-string (apply string-append inputs))) 83 | (port-count-lines! p) 84 | ;; account for the "#2d" that was read from the first line 85 | (call-with-values (λ () (parse-2dcond p "source" 1 0 1 2)) 86 | (λ x (list-ref x i)))) 87 | 88 | (define (get-graph inputs) (get-something inputs 0)) 89 | (define (get-all-lines inputs) (get-something inputs 1)) 90 | (define (get-table-column-breaks inputs) (get-something inputs 2)) 91 | (define (get-initial-space-count inputs) (get-something inputs 3)) 92 | 93 | 94 | (check-equal? (get-err-locs 95 | '("#2d\n" 96 | "╔══╦══╗\n" 97 | "║1 ║2 ║\n" 98 | "╠══╬══╣\n" 99 | "║4 ║3 ║\n" 100 | "╚══╩══╝\n")) 101 | #f) 102 | (check-equal? (get-err-locs 103 | '("#2d\n" 104 | "╔══╦══╗\n" 105 | "║λ ║2 ║\n" 106 | "╠══╬══╣\n" 107 | "║1 ║黃 ║\n" 108 | "╚══╩══╝\n")) 109 | #f) 110 | (check-equal? (get-err-locs 111 | '("#2d\n" 112 | " ╔══╦══╗\n" 113 | " ║1 ║4 ║\n" 114 | " ╠══╬══╣\n" 115 | " ║2 ║3 ║\n" 116 | " ╚══╩══╝\n")) 117 | #f) 118 | (check-equal? (get-err-locs 119 | '("#2d\n" 120 | " ╔══╦══╦══╗\n" 121 | " ║1 ║2 ║3 ║\n" 122 | " ╠══╬══╬══╣\n" 123 | " ║6 ║5 ║4 ║\n" 124 | " ╠══╬══╬══╣\n" 125 | " ║7 ║8 ║9 ║\n" 126 | " ╚══╩══╩══╝\n")) 127 | #f) 128 | (check-equal? (get-err-locs 129 | '("#2d\n" 130 | " ╔══╦══╦══╗\n" 131 | " ║ 1║ 2║ 3║\n" 132 | " ╠══╬══╩══╣\n" 133 | " ║ 4║ ║\n" 134 | " ╠══╣ 6 ║\n" 135 | " ║ 5║ ║\n" 136 | " ╚══╩═════╝\n")) 137 | #f) 138 | (check-equal? (get-err-locs 139 | '("#2d\n" 140 | " ╔══╦══╦══╗\n" 141 | " ║ 1║ 2║ 3║\n" 142 | " ╠══╬══╩══╣\n" 143 | " ║ 4║5 ║\n" 144 | " ╠══╬═════╣\n" 145 | " ║ 6║7 ║\n" 146 | " ╚══╩═════╝\n")) 147 | #f) 148 | (check-equal? (get-err-locs 149 | '("#2d\n" 150 | " ╔══╦══╦══╦══╗\n" 151 | " ║ 1║ 2║ 3║ 4║\n" 152 | " ╠══╬══╬══╩══╣\n" 153 | " ║ 4║ 5║ 6 ║\n" 154 | " ╚══╩══╩═════╝\n")) 155 | #f) 156 | (check-equal? (get-err-locs 157 | '("#2d\n" 158 | " ╔══╦══╦══╗\n" 159 | " ║1 ║2 ║3 ║\n" 160 | " ╠══╬══╬══╣\n" 161 | " ║4 ║ ║ ║\n" 162 | " ╠══╣ ║ ║\n" 163 | " ║5 ║6 ║7 ║\n" 164 | " ╚══╩══╩══╝\n")) 165 | #f) 166 | 167 | (check-equal? (get-err-locs 168 | '("#2d\n" 169 | " ╔══╦══╗\n" 170 | " ║1 ║4 ║ ;; comment\n" 171 | " ╠══╬══╣ ;; comment \n" 172 | " ║2 ║3 ║\n" 173 | " ╚══╩══╝\n")) 174 | #f) 175 | 176 | (define lines-table (hash-copy all-line-of-interest)) 177 | 178 | (parameterize ([current-lines lines-table]) 179 | (check-regexp-match #rx"expected a newline" 180 | (with-handlers ((exn:fail? exn-message)) 181 | (parameterize ([current-readtable (make-2d-readtable)]) 182 | (read (open-input-string "#2d"))))) 183 | (check-equal? (get-err-locs 184 | '("#2d\n" 185 | " ╔══╦══╗\n" 186 | " ║ ║\n" 187 | " ╠══╬══╣\n" 188 | " ║ ║ ║\n" 189 | " ╚══╩══╝\n")) 190 | (list (srcloc #f 3 2 17 1) 191 | (srcloc #f 2 2 7 1))) 192 | (check-equal? (get-err-locs 193 | '("#2d\n" 194 | " ╔══╦══╗\n" 195 | " ║ ═║ ║\n" 196 | " ╠══╬══╣\n" 197 | " ║ ║ ║\n" 198 | " ╚══╩══╝\n")) 199 | (list (srcloc #f 3 4 19 1))) 200 | (check-equal? (get-err-locs 201 | '("#2d\n" 202 | " ╔══╦══╗\n" 203 | " ║ ║ ║\n" 204 | " ╠══╬══╣\n" 205 | " ║ ║ ║\n" 206 | " ╚══╩══╝\n")) 207 | (list (srcloc #f 3 1 16 1))) 208 | (check-equal? (get-err-locs 209 | '("#2d\n" 210 | " ╔══╦══╗\n" 211 | " ║ ║ ║\n" 212 | " ╠══╬══\n" 213 | " ║ ║ ║\n" 214 | " ╚══╩══╝\n")) 215 | (list (srcloc #f 4 8 33 1))) 216 | (check-equal? (get-err-locs 217 | '("#2d\n" 218 | " ╔══╦══╗\n" 219 | " ║ ║ ║\n" 220 | " ╠═\n" 221 | " ║ ║ ║\n" 222 | " ╚══╩══╝\n")) 223 | (list (srcloc #f 4 4 29 1))) 224 | (check-equal? (get-err-locs 225 | '("#2d\n" 226 | " +----+\n" 227 | " | |\n" 228 | " +----+\n")) 229 | (list (srcloc #f 2 2 7 1))) 230 | (check-equal? (get-err-locs 231 | '("#2d\n" 232 | " \n")) 233 | (list (srcloc #f 2 0 5 3))) 234 | (check-equal? (get-err-locs 235 | '("#2d\n" 236 | " ╔══╦══\n")) 237 | (list (srcloc #f 2 8 13 1))) 238 | 239 | (check-equal? (get-err-locs 240 | '("#2d\n" 241 | " ╔══╦══╦═══╗\n" 242 | " ║ ║ ║ ║\n" 243 | " ╠══╬══╩═══╣\n" 244 | " ║ ║ ║\n" 245 | " ╠══╣ ═ ║\n" 246 | " ║ ║ ║\n" 247 | " ╚══╩══════╝\n")) 248 | (list (srcloc #f 6 8 69 1))) 249 | 250 | (check-equal? (get-err-locs 251 | '("#2d\n" 252 | " ╔══╦══╦═══╗\n" 253 | " ║ ║ ║ ║\n" 254 | " ╠══╬══╩═══╣\n" 255 | " ║ ║ ║\n" 256 | " ╠══╬══╝═══╣\n" 257 | " ║ ║ ║\n" 258 | " ╚══╩══════╝\n")) 259 | (list (srcloc #f 6 8 69 1))) 260 | 261 | (check-equal? (get-err-locs 262 | '("#2d\n" 263 | " ╔══╦═══╦═══╗\n" 264 | " ║ ║ ║ ║\n" 265 | " ╠══╬═══╬═══╣\n" 266 | " ║ ║ ║ ║\n" 267 | " ╠══╣ ═ ╠═══╣\n" 268 | " ║ ║ ║ ║\n" 269 | " ╚══╩═══╩═══╝\n")) 270 | (list (srcloc #f 6 7 72 1) 271 | (srcloc #f 6 5 70 1))) 272 | 273 | (check-equal? (get-err-locs 274 | '("#2d\n" 275 | " ╔══╦═══╦═══╗\n" 276 | " ║ ║ ║ ║\n" 277 | " ╠══╬═══╬═══╣\n" 278 | " ║ ║ ║ ║\n" 279 | " ╠══╬═ ═╬═══╣\n" 280 | " ║ ║ ║ ║\n" 281 | " ╚══╩═══╩═══╝\n")) 282 | (list (srcloc #f 6 7 72 1) 283 | (srcloc #f 6 5 70 1))) 284 | 285 | (check-equal? (get-err-locs 286 | '("#2d\n" 287 | " ╔══╦═══╦═══╗\n" 288 | " ║ ║ ║ ║\n" 289 | " ╠══╬═══╬═══╣\n" 290 | " ║ ║ ║ \n" 291 | " ╠══╬═══╬═══╣\n" 292 | " ║ ║ ║ ║\n" 293 | " ╚══╩═══╩═══╝\n")) 294 | (list (srcloc #f 5 13 63 1))) 295 | 296 | (check-equal? (get-err-locs 297 | '("#2d\n" 298 | " ╔══╦═══╦═══╗\n" 299 | " ║ ║ ║ ║\n" 300 | " ╠══╩═══╬═══╣\n" 301 | " ║ ║ ║\n" 302 | " ║ ║\n" 303 | " ║ ║ ║\n" 304 | " ╠══╦═══╬═══╣\n" 305 | " ║ ║ ║ ║\n" 306 | " ╚══╩═══╩═══╝\n")) 307 | (list (srcloc #f 6 9 74 1))) 308 | 309 | (check-equal? (get-err-locs 310 | '("#2d\n" 311 | " ╔══╦═══╦═══╗\n" 312 | " ║ ║ ║ ║\n" 313 | " ╠══╩═══╬═══╣\n" 314 | " ║ ║ ║\n" 315 | " ║ ╩ ║ ║\n" 316 | " ║ ║ ║\n" 317 | " ╠══╦═══╬═══╣\n" 318 | " ║ ║ ║ ║\n" 319 | " ╚══╩═══╩═══╝\n")) 320 | (list (srcloc #f 6 5 70 1))) 321 | 322 | (check-equal? (get-err-locs 323 | '("#2d\n" 324 | " ╔══╦═══╦═══╗\n" 325 | " ║ ║ ║ ║\n" 326 | " ╠══╩═══╬═══╣\n" 327 | " ║ ║ ║\n" 328 | " ║ \n" 329 | " ║ ║ ║\n" 330 | " ╠══╦═══╬═══╣\n" 331 | " ║ ║ ║ ║\n" 332 | " ╚══╩═══╩═══╝\n")) 333 | (list (srcloc #f 6 6 71 1))) 334 | 335 | (check-equal? (get-err-locs 336 | '("#2d\n" 337 | " ╔══╦═══╦═══╗\n" 338 | " ║ ║ ║ ║\n" 339 | " ╠══╩═══╬═══╣\n" 340 | " ║ ║ ║\n" 341 | " ╚══════╩═\n")) 342 | (list (srcloc #f 6 11 76 1))) 343 | 344 | (check-equal? (get-err-locs 345 | '("#2d\n" 346 | " ╔══╦═══╦═══╗\n" 347 | " ║ ║ ║ ║\n" 348 | " ╠══╩═══╬═══╣\n" 349 | " ║ ║ ║\n" 350 | " ╚══════\n")) 351 | (list (srcloc #f 6 9 74 1))) 352 | 353 | (check-equal? (get-err-locs 354 | '("#2d\n" 355 | " ╔══╦═══╦═══╗\n" 356 | " ║ ║ ║ ║\n" 357 | " ╠══╩═══╬═══╣\n" 358 | " ║ ║ ║\n" 359 | " ╚══════╩═══X\n")) 360 | (list (srcloc #f 6 13 78 1))) 361 | 362 | (check-equal? (get-err-locs 363 | '("#2d\n" 364 | " ╔══╦═══╦═══╗\n" 365 | " ║ ║ ║ ║\n" 366 | " ╠══╩═══╬═══╣\n" 367 | " ║ ║ ║\n" 368 | " ╚══════╩══X╝\n")) 369 | (list (srcloc #f 6 12 77 1))) 370 | 371 | (check-equal? (get-err-locs 372 | '("#2d\n" 373 | " ╔══╦═══╦═══╗\n" 374 | " ║ ║ ║ ║\n" 375 | " ╠══╩═══╬═══╣\n" 376 | " ║ ║ ║ NOT WHITESPACE\n" 377 | " ╚══════╩═══╝\n")) 378 | (list (srcloc #f 5 19 69 1))) 379 | 380 | (check-equal? (get-err-locs 381 | '("#2d\n" 382 | "╔══╦-══╗\n" 383 | "║ ║ ║\n" 384 | "╠══╬-══╣\n" 385 | "║ ║ ║\n" 386 | "╚══╩-══╝\n")) 387 | (list (srcloc #f 2 4 9 1)))) 388 | 389 | (let ([lines (hash-map lines-table (λ (x y) x))]) 390 | (unless (null? lines) 391 | (eprintf "no test case for errors on lines: ~s\n" 392 | (sort lines <)))) 393 | 394 | 395 | (check-equal? (get-graph 396 | '(" ╔══╦══╦══╗\n" 397 | " ║ 1║ 2║ 3║\n" 398 | " ╠══╬══╩══╣\n" 399 | " ║ 4║ ║\n" 400 | " ╠══╣ 6 ║\n" 401 | " ║ 5║ ║\n" 402 | " ╚══╩═════╝\n")) 403 | (make-hash 404 | (list (cons (list 0 0) (set)) 405 | (cons (list 0 1) (set)) 406 | (cons (list 0 2) (set)) 407 | (cons (list 1 0) (set)) 408 | (cons (list 2 0) (set)) 409 | 410 | (cons (list 1 1) (set (list 1 2) (list 2 1))) 411 | (cons (list 2 1) (set (list 1 1) (list 2 2))) 412 | (cons (list 1 2) (set (list 1 1) (list 2 2))) 413 | (cons (list 2 2) (set (list 1 2) (list 2 1)))))) 414 | 415 | (check-equal? (get-graph 416 | '(" ╔══╦══╦══╗\n" 417 | " ║1 ║2 ║3 ║\n" 418 | " ╠══╬══╬══╣\n" 419 | " ║6 ║5 ║4 ║\n" 420 | " ╠══╬══╬══╣\n" 421 | " ║7 ║8 ║9 ║\n" 422 | " ╚══╩══╩══╝\n")) 423 | (make-hash 424 | (list (cons (list 0 0) (set)) 425 | (cons (list 0 1) (set)) 426 | (cons (list 0 2) (set)) 427 | (cons (list 1 0) (set)) 428 | (cons (list 1 1) (set)) 429 | (cons (list 1 2) (set)) 430 | (cons (list 2 0) (set)) 431 | (cons (list 2 1) (set)) 432 | (cons (list 2 2) (set))))) 433 | 434 | (check-equal? (get-graph 435 | '(" ╔══╦══╦══╦══╗\n" 436 | " ║1 ║2 ║3 ║4 ║\n" 437 | " ╠══╬══╩══╩══╣\n" 438 | " ║6 ║5 ║\n" 439 | " ╠══╣ ╔══╗ ║\n" 440 | " ║7 ║ ║10║ ║\n" 441 | " ╠══╣ ╚══╝ ║\n" 442 | " ║7 ║ ║\n" 443 | " ╚══╩════════╝\n")) 444 | (make-hash 445 | (list (cons (list 0 0) (set)) 446 | (cons (list 0 1) (set)) 447 | (cons (list 0 2) (set)) 448 | (cons (list 0 3) (set)) 449 | 450 | (cons (list 1 0) (set)) 451 | (cons (list 1 1) (set (list 1 2) (list 2 1))) 452 | (cons (list 1 2) (set (list 1 1) (list 1 3))) 453 | (cons (list 1 3) (set (list 1 2) (list 2 3))) 454 | 455 | (cons (list 2 0) (set)) 456 | (cons (list 2 1) (set (list 1 1) (list 3 1))) 457 | (cons (list 2 2) (set)) 458 | (cons (list 2 3) (set (list 1 3) (list 3 3))) 459 | 460 | (cons (list 3 0) (set)) 461 | (cons (list 3 1) (set (list 2 1) (list 3 2))) 462 | (cons (list 3 2) (set (list 3 1) (list 3 3))) 463 | (cons (list 3 3) (set (list 3 2) (list 2 3)))))) 464 | 465 | (check-equal? (get-all-lines '(" ╔══╦══╗\n" 466 | " ║1 ║ ║\r" 467 | " ╠══╬══╣\r\n" 468 | " ║2 ║ ║\r" 469 | " ╠══╬══╣\n" 470 | " ║3 ║ ║\n" 471 | " ╚══╩══╝\n")) 472 | '#((" ╔══╦══╗\n" " ║1 ║ ║\r") 473 | (" ╠══╬══╣\r\n" " ║2 ║ ║\r") 474 | (" ╠══╬══╣\n" " ║3 ║ ║\n"))) 475 | 476 | (check-equal? (get-table-column-breaks '(" ╔══╦══╗\n" 477 | " ║1 ║ ║\n" 478 | " ╠══╬══╣\n" 479 | " ║2 ║ ║\n" 480 | " ╠══╬══╣\n" 481 | " ║3 ║ ║\n" 482 | " ╚══╩══╝\n")) 483 | (list 2 2)) 484 | (check-equal? (get-initial-space-count '(" ╔══╦══╗\n" 485 | " ║1 ║ ║\n" 486 | " ╠══╬══╣\n" 487 | " ║2 ║ ║\n" 488 | " ╠══╬══╣\n" 489 | " ║3 ║ ║\n" 490 | " ╚══╩══╝\n")) 491 | 2) 492 | 493 | (check-equal? (close-cell-graph (make-hash) 2 2) 494 | (set (set (list 0 0)) 495 | (set (list 0 1)) 496 | (set (list 1 0)) 497 | (set (list 1 1)))) 498 | 499 | (check-equal? (close-cell-graph (make-hash 500 | (list 501 | (cons (list 0 0) (set (list 0 1))))) 502 | 2 2) 503 | (set (set (list 0 0) (list 0 1)) 504 | (set (list 1 0)) 505 | (set (list 1 1)))) 506 | 507 | 508 | (check-equal? (close-cell-graph (make-hash 509 | (list 510 | (cons (list 0 0) (set (list 0 1))) 511 | (cons (list 0 1) (set (list 1 1))))) 512 | 2 2) 513 | (set (set (list 0 0) (list 0 1) (list 1 1)) 514 | (set (list 1 0)))) 515 | (check-equal? (close-cell-graph (make-hash 516 | (list 517 | (cons (list 0 0) (set (list 0 1))) 518 | (cons (list 0 1) (set (list 1 1))) 519 | (cons (list 1 1) (set (list 1 0))))) 520 | 2 2) 521 | (set (set (list 0 0) (list 0 1) (list 1 1) (list 1 0)))) 522 | 523 | (check-true (compare/xy (list 0 0) (list 1 1))) 524 | (check-false (compare/xy (list 1 1) (list 0 0))) 525 | (check-true (compare/xy (list 1 0) (list 1 1))) 526 | (check-false (compare/xy (list 1 1) (list 1 0))) 527 | (check-false (compare/xy (list 1 0) (list 1 0))) 528 | 529 | (check-equal? (smallest-representative (set (list 0 0) (list 1 0) (list 0 1) (list 1 1))) 530 | (list 0 0)) 531 | (check-equal? (smallest-representative (set (list 1 1) (list 0 1) (list 1 0) (list 0 0))) 532 | (list 0 0)) 533 | 534 | (let () 535 | (define scratch (string-copy " ")) 536 | (fill-scratch-string (set '(0 0)) 537 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n")) 538 | scratch 539 | '(2 2) 540 | 0) 541 | (check-equal? scratch 542 | " \n 12 \n \n \n")) 543 | 544 | (let () 545 | (define scratch (string-copy " ")) 546 | (fill-scratch-string (set '(1 0)) 547 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n")) 548 | scratch 549 | '(2 2) 550 | 0) 551 | (check-equal? scratch 552 | " \n 34 \n \n \n")) 553 | 554 | (let () 555 | (define scratch (string-copy " ")) 556 | (fill-scratch-string (set '(0 1)) 557 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n")) 558 | scratch 559 | '(2 2) 560 | 0) 561 | (check-equal? scratch 562 | " \n \n \n 56 \n")) 563 | 564 | (let () 565 | (define scratch (string-copy " ")) 566 | (fill-scratch-string (set '(1 1)) 567 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n")) 568 | scratch 569 | '(2 2) 570 | 0) 571 | (check-equal? scratch 572 | " \n \n \n 78 \n")) 573 | 574 | (let () 575 | (define scratch (string-copy " \n 34 \n \n \n")) 576 | (fill-scratch-string (set '(1 0) '(1 1)) 577 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╣56║\n" "║78║90║\n")) 578 | scratch 579 | '(2 2) 580 | 0) 581 | (check-equal? scratch 582 | " \n 34 \n 56 \n 90 \n")) 583 | 584 | (let () 585 | (define scratch (string-copy " \n 34 \n \n \n")) 586 | (fill-scratch-string (set '(0 1) '(1 1)) 587 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╩══╣\n" "║56789║\n")) 588 | scratch 589 | '(2 2) 590 | 0) 591 | (check-equal? scratch 592 | " \n \n \n 56789 \n")) 593 | 594 | (let () 595 | (define scratch (string-copy " \n 34 \n \n \n")) 596 | (fill-scratch-string (set '(0 1) '(1 0) '(1 1)) 597 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╝56║\n" "║7890A║\n")) 598 | scratch 599 | '(2 2) 600 | 0) 601 | (check-equal? scratch 602 | " \n 34 \n 56 \n 7890A \n")) 603 | 604 | (let () 605 | (define scratch (string-copy " ")) 606 | (fill-scratch-string (set '(0 0)) 607 | #(("╔═════╗\n" "║12345║\n" "║67890║\n" "║ABCDE║\n")) 608 | scratch 609 | '(5) 610 | 0) 611 | 612 | (check-equal? scratch 613 | " \n 12345 \n 67890 \n ABCDE \n")) 614 | 615 | (let () 616 | (define scratch (make-string 66 #\space)) 617 | (fill-scratch-string (set '(1 2) '(1 1) '(2 2) '(2 1)) 618 | #(("╔══╦══╦══╗\n" "║12║34║56║\n") 619 | ("╠══╬══╩══╣\n" "║78║90ABC║\n") 620 | ("╠══╣DEFGH║\n" "║IJ║KLMNO║\n")) 621 | scratch 622 | '(2 2 2) 623 | 0) 624 | 625 | (check-equal? scratch 626 | " \n \n \n 90ABC \n DEFGH \n KLMNO \n")) 627 | 628 | (let () 629 | (define scratch (make-string 120 #\space)) 630 | (fill-scratch-string 631 | (set '(1 2) '(1 3) '(2 3)) 632 | #(("╔═╦════╦═════╗\n" "║1║2345║67890║\n") 633 | ("╠═╬════╩═════╣\n" "║a║bcdefghijk║\n") 634 | ("╠═╬════╗lmnop║\n" "║q║rstu║vwxyz║\n") 635 | ("╠═╣ABCD╚═════╣\n" "║E║FGHIJKLMNO║\n")) 636 | scratch 637 | '(1 4 5) 638 | 0) 639 | (check-equal? (string-append 640 | " \n" 641 | " \n" 642 | " \n" 643 | " \n" 644 | " \n" 645 | " rstu \n" 646 | " ABCD \n" 647 | " FGHIJKLMNO \n") 648 | scratch)) 649 | 650 | (let () 651 | (define scratch (make-string 495 #\space)) 652 | (fill-scratch-string 653 | (set '(1 2) '(1 3) '(1 4) '(2 3) '(2 4) '(3 4)) 654 | #(("╔════════╦════╦═════╦════════╦═════════════╗\n" 655 | "║ ║'Int║'Real║'Complex║ `(-> ,c ,d) ║\n") 656 | ("╠════════╬════╩═════╩════════╬═════════════╣\n" 657 | "║'Int ║ ║ ║\n") 658 | ("╠════════╬════╗ #t ║ ║\n" 659 | "║'Real ║ ║ ║ #f ║\n") 660 | ("╠════════╣ ╚═════╗ ║ ║\n" 661 | "║'Complex║ ║ ║ ║\n") 662 | ("╠════════╣ ╚════════╬═════════════╣\n" 663 | "║`(-> ,a ║ #f ║(and (≤ c a) ║\n" 664 | "║ ,b)║ ║ (≤ b d))║\n")) 665 | scratch 666 | '(8 4 5 8 13) 667 | 0) 668 | ;; just make sure there are no border characters in there. 669 | (check-regexp-match #rx"^[\n#f ]*$" scratch)) 670 | 671 | (let () 672 | (define str (make-string 84 #\space)) 673 | (fill-scratch-string (set '(1 2) '(1 1) '(2 1)) 674 | '#(("╔═══╦═══╦═══╗\n" 675 | "║ ║ a ║ b ║\n") 676 | ("╠═══╬═══╩═══╣\n" 677 | "║ c ║ 1 ║\n") 678 | ("╠═══╣ ╔═══╣\n" 679 | "║ d ║ ║ 2 ║\n")) 680 | str 681 | '(3 3 3) 682 | 0) 683 | (check-equal? str 684 | " \n \n \n 1 \n \n \n")) 685 | 686 | (let () 687 | (define scratch (string-copy " ")) 688 | (check-equal? (fill-scratch-string (set '(0 0)) 689 | #(("╔══╦══╗\n" "║12║34║\n") ("╠══╬══╣\n" "║56║78║\n")) 690 | scratch 691 | '(2 2) 692 | 0 693 | #t) 694 | '((10 . 12)))) 695 | 696 | (let () 697 | (define sp (open-input-string 698 | (string-append "#(#2d\n" 699 | " ╔══╦══╗\n" 700 | " ║1 ║2 ║\n" 701 | " ╠══╬══╣\n" 702 | " ║4 ║3 ║\n" 703 | " ╚══╩══╝)1\n"))) 704 | (parameterize ([current-readtable (make-2d-readtable)]) 705 | (check-true (vector? (read sp))) 706 | (check-equal? (read sp) 1))) 707 | 708 | 709 | (let () 710 | (define sp (open-input-string "#2dwhatever\n")) 711 | (port-count-lines! sp) 712 | (define exn 713 | (with-handlers ((exn:fail:read:eof? values)) 714 | (parameterize ([current-readtable (make-2d-readtable)]) 715 | (read sp)))) 716 | (check-regexp-match #rx"expected eof" (exn-message exn)) 717 | (check-equal? (exn:fail:read-srclocs exn) 718 | (list (srcloc #f 1 0 1 12)))) 719 | -------------------------------------------------------------------------------- /2d/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | (define version "1.0") 5 | (define deps '("2d-lib" "2d-doc")) 6 | (define implies '("2d-lib" "2d-doc")) 7 | (define pkg-desc "2d syntax") 8 | (define pkg-authors '(robby)) 9 | 10 | (define license 11 | '(Apache-2.0 OR MIT)) 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 2d 2 | 3 | This the source for the Racket packages: "2d", "2d-doc", "2d-lib", "2d-test". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/2d/pulls 22 | [issue]: https://github.com/racket/2d/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | --------------------------------------------------------------------------------