reader.rkt (21032B)
1 #lang racket/base 2 3 (require tests/eli-tester (prefix-in scr: scribble/reader) racket/list) 4 5 (define the-tests #<<END-OF-TESTS 6 7 ;; format: 8 ;; * a line with only `-'s marks the boundary between tests 9 ;; * -<token>-> marks a <token> kind of reader test 10 ;; (put on a new line if whitespace matters) 11 ;; * lines with semicolon comments flushed at the left column ignored, 12 13 --- 14 ;; -------------------- simple uses, test identifiers 15 --- 16 @foo -@-> foo 17 --- 18 @foo{} -@-> (foo) 19 --- 20 @foo[] -@-> (foo) 21 --- 22 @foo[]{} -@-> (foo) 23 --- 24 foo@ -@-> foo@ 25 --- 26 fo@o -@-> fo@o 27 --- 28 \@foo -@-> @foo 29 --- 30 |@foo| -@-> @foo 31 --- 32 @foo@bar -@-> foo@bar 33 --- 34 @foo@bar. -@-> foo@bar. 35 --- 36 @foo@bar: -@-> foo@bar: 37 --- 38 @foo@bar; -@-> foo@bar 39 --- 40 @foo[]@bar{} -@-> (foo) (bar) 41 --- 42 @foo{foo@|bar|.} 43 -@-> 44 (foo "foo" bar ".") 45 --- 46 @foo{foo@bar;} 47 -@-> 48 (foo "foo" bar ";") 49 --- 50 (define |@foo| '\@bar@baz) -@-> (define @foo '@bar@baz) 51 --- 52 @foo{foo@2.} 53 -@-> 54 (foo "foo" 2.0) 55 --- 56 ;; -------------------- simple args and texts 57 --- 58 @foo{bar} -@-> (foo "bar") 59 --- 60 @foo[]{bar} -@-> (foo "bar") 61 --- 62 @foo[bar] -@-> (foo bar) 63 --- 64 @foo[bar]{} -@-> (foo bar) 65 --- 66 @foo[bar][baz] -@-> (foo bar) [baz] 67 --- 68 @foo[bar]{baz} -@-> (foo bar "baz") 69 --- 70 @foo[bar]{baz}[blah] -@-> (foo bar "baz") [blah] 71 --- 72 @foo[bar]{baz}@foo[blah] -@-> (foo bar "baz") (foo blah) 73 --- 74 @foo[#:x y]{bar} -@-> (foo #:x y "bar") 75 --- 76 @foo[1 (* 2 3)]{bar} -@-> (foo 1 (* 2 3) "bar") 77 --- 78 @foo[@bar{...}]{blah} 79 -@-> 80 (foo (bar "...") "blah") 81 --- 82 ;; -------------------- no exprs or text 83 --- 84 @{} -@-> () 85 --- 86 @[] -@-> () 87 --- 88 @{foo} -@-> ("foo") 89 --- 90 @[foo] -@-> (foo) 91 --- 92 @{@foo bar} -@-> (foo " bar") 93 --- 94 @|{blah}| -@-> ("blah") 95 --- 96 @|{blah|@foo bleh}| -@-> ("blah" foo " bleh") 97 --- 98 @|{|@meh blah|@foo bleh}| -@-> (meh " blah" foo " bleh") 99 --- 100 ;; -------------------- newlines and spaces in text 101 --- 102 @foo{bar baz} -@-> (foo "bar baz") 103 --- 104 @foo{bar baz} -@-> (foo "bar baz") 105 --- 106 @foo{ bar } -@-> (foo " bar ") 107 --- 108 @foo{ bar } -@-> (foo " bar ") 109 --- 110 @foo{ } -@-> (foo " ") 111 --- 112 @foo{ } -@-> (foo " ") 113 --- 114 @foo[1]{bar baz} -@-> (foo 1 "bar baz") 115 --- 116 @foo[1]{bar baz} -@-> (foo 1 "bar baz") 117 --- 118 @foo[1]{ bar } -@-> (foo 1 " bar ") 119 --- 120 @foo[1]{ bar } -@-> (foo 1 " bar ") 121 --- 122 @foo[1]{ } -@-> (foo 1 " ") 123 --- 124 @foo[1]{ } -@-> (foo 1 " ") 125 --- 126 @foo{bar baz 127 blah} 128 -@-> 129 (foo "bar baz" "\n" "blah") 130 --- 131 @foo[1]{bar baz 132 blah} 133 -@-> 134 (foo 1 "bar baz" "\n" "blah") 135 --- 136 @foo{bar baz 137 138 blah} 139 -@-> 140 (foo "bar baz" "\n" "\n" "blah") 141 --- 142 @foo{bar baz 143 144 145 blah} 146 -@-> 147 (foo "bar baz" "\n" "\n" "\n" "blah") 148 --- 149 @foo{bar 150 } 151 -@-> 152 (foo "bar") 153 --- 154 @foo{ 155 bar} 156 -@-> 157 (foo "bar") 158 --- 159 @foo{ 160 bar 161 } 162 -@-> 163 (foo "bar") 164 --- 165 @foo{ 166 167 bar 168 } 169 -@-> 170 (foo "\n" "bar") 171 --- 172 @foo{ 173 bar 174 175 } 176 -@-> 177 (foo "bar" "\n") 178 --- 179 @foo{ 180 181 bar 182 183 } 184 -@-> 185 (foo "\n" "bar" "\n") 186 --- 187 @foo{ 188 } 189 -@-> 190 (foo "\n") 191 --- 192 @foo{ 193 194 } 195 -@-> 196 (foo "\n" "\n") 197 --- 198 @foo{ 199 200 201 } 202 -@-> 203 (foo "\n" "\n" "\n") 204 --- 205 ;; -------------------- nested forms 206 --- 207 @foo{@bar} -@-> (foo bar) 208 --- 209 @foo{@bar{}} -@-> (foo (bar)) 210 --- 211 @foo{111@bar{222}333} -@-> (foo "111" (bar "222") "333") 212 --- 213 @foo{111@bar[222]333} -@-> (foo "111" (bar 222) "333") 214 --- 215 @foo[111 @bar{222} 333] -@-> (foo 111 (bar "222") 333) 216 --- 217 @foo[111 @bar{222}333] -@-> (foo 111 (bar "222") 333) 218 --- 219 @foo[111 @bar[222]333] -@-> (foo 111 (bar 222) 333) 220 --- 221 @foo[111 @bar 222] -@-> (foo 111 bar 222) 222 --- 223 @foo{111 @bar 222} -@-> (foo "111 " bar " 222") 224 --- 225 @foo{@bar 111} -@-> (foo bar " 111") 226 --- 227 @foo{111 @bar} -@-> (foo "111 " bar) 228 --- 229 @foo{ @bar } -@-> (foo " " bar " ") 230 --- 231 @foo{bar @baz[3] 232 blah} 233 -@-> 234 (foo "bar " (baz 3) "\n" "blah") 235 --- 236 @foo{bar @baz{3} 237 blah} 238 -@-> 239 (foo "bar " (baz "3") "\n" "blah") 240 --- 241 @foo{bar @baz[2 3]{4 5} 242 blah} 243 -@-> 244 (foo "bar " (baz 2 3 "4 5") "\n" "blah") 245 --- 246 @foo{bar @baz[2 3] {4 5}} 247 -@-> 248 (foo "bar " (baz 2 3) " {4 5}") 249 --- 250 ;; -------------------- cannot have spaces before args or text 251 --- 252 @foo [bar] -@-> foo (bar) 253 --- 254 @foo {bar} -@-> foo (bar) 255 --- 256 @foo[bar] {baz} -@-> (foo bar) (baz) 257 --- 258 @foo{bar @baz {bleh}} -@-> (foo "bar " baz " {bleh}") 259 --- 260 ;; -------------------- expression escapes, operators, currying 261 --- 262 @foo{1 @(+ 2 3) 4} -@-> (foo "1 " (+ 2 3) " 4") 263 --- 264 @(lambda (x) x){blah} -@-> ((lambda (x) x) "blah") 265 --- 266 @(lambda (x) x)[blah] -@-> ((lambda (x) x) blah) 267 --- 268 @foo{bar}{baz} -@-> (foo "bar") (baz) 269 --- 270 @@foo{bar}{baz} -@-> ((foo "bar") "baz") 271 --- 272 @@foo{bar} {baz} -@-> (foo "bar") (baz) 273 --- 274 @@foo{bar}{baz}{} -@-> ((foo "bar") "baz") () 275 --- 276 @@@foo{bar}{baz}{} -@-> (((foo "bar") "baz")) 277 --- 278 @@@foo[]{}[][] -@-> (((foo))) 279 --- 280 @@@foo[]{}[][][] -@-> (((foo))) () 281 --- 282 @foo{foo@|3|.} 283 -@-> 284 (foo "foo" 3 ".") 285 --- 286 @foo{foo@|(f 1)|{bar}} 287 -@-> 288 (foo "foo" (f 1) "{bar}") 289 --- 290 @foo{foo@|bar|[1]{baz}} 291 -@-> 292 (foo "foo" bar "[1]{baz}") 293 --- 294 ;; -------------------- pulling punctuations outside 295 --- 296 @'foo -@-> 'foo 297 --- 298 @'foo[1 2] -@-> '(foo 1 2) 299 --- 300 @'foo{bar} -@-> '(foo "bar") 301 --- 302 @`foo{bar} -@-> `(foo "bar") 303 --- 304 @,foo{bar} -@-> ,(foo "bar") 305 --- 306 @,@foo{bar} -@-> ,@(foo "bar") 307 --- 308 @`',foo{bar} -@-> `',(foo "bar") 309 --- 310 @`',`',foo{bar} -@-> `',`',(foo "bar") 311 --- 312 @``'',,foo{bar} -@-> ``'',,(foo "bar") 313 --- 314 @`',@foo{bar} -@-> `',@(foo "bar") 315 --- 316 @`',@`',@foo{bar} -@-> `',@`',@(foo "bar") 317 --- 318 @``'',@,@foo{bar} -@-> ``'',@,@(foo "bar") 319 --- 320 @``'',,,@,@foo{bar} -@-> ``'',,,@,@(foo "bar") 321 --- 322 @#'foo{bar} -@-> #'(foo "bar") 323 --- 324 @#`foo{bar} -@-> #`(foo "bar") 325 --- 326 @#,foo{bar} -@-> #,(foo "bar") 327 --- 328 @#''foo{bar} -@-> #''(foo "bar") 329 --- 330 @#`'#,foo{bar} -@-> #`'#,(foo "bar") 331 --- 332 @`foo{123 @,bar{456} 789} 333 -@-> 334 `(foo "123 " ,(bar "456") " 789") 335 --- 336 @`(unquote foo){blah} 337 -@-> 338 `(,foo "blah") 339 --- 340 ;; -------------------- balanced braces are allowed 341 --- 342 @foo{f{o}o} -@-> (foo "f{o}o") 343 --- 344 @foo{{{}}{}} -@-> (foo "{{}}{}") 345 --- 346 @foo{f[o]o} -@-> (foo "f[o]o") 347 --- 348 @foo{[{}]{}} -@-> (foo "[{}]{}") 349 --- 350 ;; -------------------- string escapes 351 --- 352 @foo{x@"y"z} -@-> (foo "xyz") 353 --- 354 @foo{A @"}" marks the end} 355 -@-> 356 (foo "A } marks the end") 357 --- 358 @foo{The prefix is: @"@".} 359 -@-> 360 (foo "The prefix is: @.") 361 -- 362 @foo{@"@x{y}" => (x "y")} 363 -@-> 364 (foo "@x{y} => (x \"y\")") 365 --- 366 ;; -------------------- alternative delimiters 367 --- 368 @foo|{...}| -@-> (foo "...") 369 --- 370 @foo|{"}" after "{"}| -@-> (foo "\"}\" after \"{\"") 371 --- 372 @foo|{Nesting |{is}| ok}| -@-> (foo "Nesting |{is}| ok") 373 --- 374 @foo|{Nested @form{not}}| -@-> (foo "Nested @form{not}") 375 --- 376 @foo|{Nested |@form|{yes}|}| -@-> (foo "Nested " (form "yes")) 377 --- 378 @foo|{Nested |@form{indep@{end}ence}}| 379 -@-> 380 (foo "Nested " (form "indep" ("end") "ence")) 381 --- 382 @foo|{Nested |@|name|}| -@-> (foo "Nested " name) 383 --- 384 @foo|{With 385 |@bar{multiple} 386 lines.}| 387 -@-> 388 (foo "With" "\n" (bar "multiple") "\n" "lines.") 389 --- 390 @t|{In |@i|{sub|@"@"s}| too}| -@-> (t "In " (i "sub@s") " too") 391 --- 392 @foo|<<<{@x{foo} |@{bar}|.}>>>| -@-> (foo "@x{foo} |@{bar}|.") 393 --- 394 @foo|<<<{@x{foo} |<<<@{bar}|.}>>>| -@-> (foo "@x{foo} " ("bar") "|.") 395 --- 396 @foo|!!{X |!!@b{Y}...}!!| -@-> (foo "X " (b "Y") "...") 397 --- 398 ;; -------------------- comments 399 --- 400 (1 2 @; comment 401 3 4) 402 -@-> 403 (1 2 3 4) 404 --- 405 @foo{bar @; comment 406 baz@; 407 blah} 408 -@-> 409 (foo "bar bazblah") 410 --- 411 @foo{bar @; comment, with space and newline 412 413 baz} 414 -@-> 415 (foo "bar " "\n" "baz") 416 --- 417 hello @; comment at eof 418 -@-> 419 hello 420 --- 421 @foo{bar @;{a balanced comment} baz} 422 -@-> 423 (foo "bar baz") 424 --- 425 @foo|{bar @;{a non-comment} baz}| 426 -@-> 427 (foo "bar @;{a non-comment} baz") 428 --- 429 @foo|{bar |@;{a balanced comment again} baz}| 430 -@-> 431 (foo "bar baz") 432 --- 433 @foo{First line@;{there is still a 434 newline here;} 435 Second line} 436 -@-> 437 (foo "First line" "\n" "Second line") 438 --- 439 @foo{A long @; 440 single-@; 441 string arg.} 442 -@-> 443 (foo "A long single-string arg.") 444 --- 445 ;; -------------------- indentation management 446 --- 447 @foo{ bar 448 baz } 449 -@-> 450 (foo " bar" "\n" "baz ") 451 --- 452 @foo{bar 453 } 454 -@-> 455 (foo "bar") 456 --- 457 @foo{ 458 bar} 459 -@-> 460 (foo "bar") 461 --- 462 @foo{ 463 bar 464 } 465 -@-> 466 (foo "bar") 467 --- 468 @foo{ 469 470 bar 471 472 } 473 -@-> 474 (foo "\n" "bar" "\n") 475 --- 476 @foo{ 477 bar 478 479 baz 480 } 481 -@-> 482 (foo "bar" "\n" "\n" "baz") 483 --- 484 @foo{ 485 } 486 -@-> 487 (foo "\n") 488 --- 489 @foo{ 490 bar 491 baz 492 blah 493 } 494 -@-> 495 (foo "bar" "\n" "baz" "\n" "blah") 496 --- 497 @foo{ 498 begin 499 x++; 500 end} 501 -@-> 502 (foo "begin" "\n" " " "x++;" "\n" "end") 503 --- 504 @foo{ 505 a 506 b 507 c} 508 -@-> 509 (foo " " "a" "\n" " " "b" "\n" "c") 510 --- 511 @foo{bar 512 baz 513 bbb} 514 -@-> 515 (foo "bar" "\n" " " "baz" "\n" "bbb") 516 --- 517 ;; requires location tracking 518 @foo{ bar 519 baz 520 bbb} 521 -@-> 522 (foo " bar" "\n" " " "baz" "\n" " " "bbb") 523 --- 524 @foo{bar 525 baz 526 bbb} 527 -@-> 528 (foo "bar" "\n" "baz" "\n" "bbb") 529 --- 530 @foo{ bar 531 baz 532 bbb} 533 -@-> 534 (foo " bar" "\n" "baz" "\n" "bbb") 535 --- 536 @foo{ bar 537 baz 538 bbb} 539 -@-> 540 (foo " bar" "\n" "baz" "\n" " " "bbb") 541 --- 542 @text{Some @b{bold 543 text}, and 544 more text.} 545 -@-> 546 (text "Some " (b "bold" "\n" "text") ", and" "\n" "more text.") 547 --- 548 @code{ 549 begin 550 i = 1, r = 1 551 @bold{while i < n do 552 r *= i++ 553 done} 554 end 555 } 556 -@-> 557 (code "begin" "\n" 558 " " "i = 1, r = 1" "\n" 559 " " (bold "while i < n do" "\n" 560 " " "r *= i++" "\n" 561 "done") "\n" 562 "end") 563 --- 564 @foo{x1 565 x2@; 566 y2 567 x3@;{ 568 ;}y3 569 x4@| 570 |y4 571 x5} 572 -@-> 573 (foo "x1" "\n" "x2y2" "\n" "x3y3" "\n" "x4" "y4" "\n" "x5") 574 --- 575 ;; -------------------- ||-quotes for artificial separators and multi-exprs 576 --- 577 @foo{x@||z} -@-> (foo "x" "z") 578 --- 579 @foo{x@|"y"|z} -@-> (foo "x" "y" "z") 580 --- 581 @foo{x@|"y" "z"|} -@-> (foo "x" "y" "z") 582 --- 583 @foo{x@|1 (+ 2 3) 4|y} -@-> (foo "x" 1 (+ 2 3) 4 "y") 584 --- 585 @foo{x@|* 586 *|y} 587 -@-> 588 (foo "x" * * "y") 589 --- 590 @foo{Alice@||Bob@| 591 |Carol} 592 -@-> 593 (foo "Alice" "Bob" "Carol") 594 --- 595 @foo{Alice@||Bob@| x 596 |Carol} 597 -@-> 598 (foo "Alice" "Bob" x "Carol") 599 --- 600 @foo{@|| 601 bar 602 @||} 603 -@-> 604 (foo "\n" "bar" "\n") 605 --- 606 @foo{ 607 @|| bar @|| 608 @|| baz} 609 -@-> 610 (foo " bar " "\n" " baz") 611 --- 612 @foo{bar 613 @|baz| bbb 614 @|x1 x2| x3 x4 615 @|| waaaah 616 } 617 -@-> 618 (foo "bar" "\n" baz " bbb" "\n" x1 x2 " x3 x4" "\n" " waaaah") 619 --- 620 ;; -------------------- inside-reader 621 --- 622 foo bar baz -@i-> "foo bar baz" 623 --- 624 foo @bar baz -@i-> "foo " bar " baz" 625 --- 626 foo @bar{blah} baz -@i-> "foo " (bar "blah") " baz" 627 --- 628 {{{ -@i-> "{{{" 629 --- 630 }}} -@i-> "}}}" 631 --- 632 foo 633 bar 634 baz 635 -@i-> 636 "foo" "\n" " " "bar" "\n" "baz" 637 --- 638 foo 639 bar 640 baz 641 -@i-> 642 " foo" "\n" " " "bar" "\n" " " "baz" 643 --- 644 ;; -------------------- using a different command character 645 --- 646 \foo 647 -\-> 648 foo 649 --- 650 \foo[1]{bar 651 baz \nested|{\form{}}| 652 blah} 653 -\-> 654 (foo 1 "bar" "\n" " " "baz " (nested "\\form{}") "\n" "blah") 655 --- 656 \foo 657 -\i-> 658 foo 659 --- 660 \foo[1]{bar 661 baz \nested|{\form{}}| 662 blah} 663 \bar[] 664 -\i-> 665 (foo 1 "bar" "\n" " " "baz " (nested "\\form{}") "\n" "blah") "\n" (bar) 666 --- 667 ;; -------------------- syntax information 668 --- 669 foo 670 -@syntax-> (stx: line= 1 column= 0 position= 1 span= 3) 671 --- 672 \foo 673 |foo| 674 -@syntax-> 675 (stx: line= 1 column= 0 position= 1 span= 4) 676 (stx: line= 2 column= 0 position= 6 span= 5) 677 --- 678 (foo bar) 679 -@syntax-> ((stx: line= 1 column= 1 position= 2 span= 3) 680 (stx: line= 1 column= 5 position= 6 span= 3)) 681 --- 682 ;; this test should break soon 683 @foo 684 -@syntax-> 685 (stx: line= 1 column= 1 position= 2 span= 3) 686 ;; NOT this: (stx: line= 1 column= 0 position= 1 span= 4) 687 --- 688 ;; -------------------- errors 689 --- 690 ( -@error-> "inp:1:0: read: expected a `)` to close `(`" ; check -@error-> 691 --- 692 @foo{ -@error-> #rx":1:0: missing closing `}`$" 693 --- 694 \foo{ -\error-> #rx":1:0: missing closing `}`$" 695 --- 696 @foo{@bar{ -@error-> #rx":1:5: missing closing `}`$" 697 --- 698 \foo{\bar{ -\error-> #rx":1:5: missing closing `}`$" 699 --- 700 @foo{@bar{} -@error-> #rx":1:0: missing closing `}`$" 701 --- 702 @foo{@bar|{} -@error-> #rx":1:5: missing closing `}\\|`$" 703 --- 704 @foo{@bar|-{} -@error-> #rx":1:5: missing closing `}-\\|`$" 705 --- 706 @foo{@bar|-{} -@error-> #rx":1:5: missing closing `}-\\|`$" 707 --- 708 \foo{\bar|-{} -\error-> #rx":1:5: missing closing `}-\\|`$" 709 --- 710 @foo{@" -@error-> #rx":1:6: read-syntax: expected a closing `\"`$" 711 ;; " <-- (balance this file) 712 --- 713 \foo{\" -\error-> #rx":1:6: read-syntax: expected a closing `\"`$" 714 --- 715 @|1 2| 716 -@error-> 717 #rx"a @|...| form in Scheme mode must have exactly one escaped expression" 718 --- 719 @|| 720 -@error-> 721 #rx"a @|...| form in Scheme mode must have exactly one escaped expression" 722 --- 723 \|1 2| 724 -\error-> 725 #rx"a \\\\|...| form in Scheme mode must have exactly one escaped expression" 726 --- 727 \|| 728 -\error-> 729 #rx"a \\\\|...| form in Scheme mode must have exactly one escaped expression" 730 --- 731 ;; -------------------- some code tests 732 --- 733 @string-append{1 @(number->string (+ 2 3)) 4} -@eval-> "1 5 4" 734 --- 735 (let* ([formatter (lambda (fmt) 736 (lambda args (format fmt (apply string-append args))))] 737 [bf (formatter "*~a*")] 738 [it (formatter "/~a/")] 739 [ul (formatter "_~a_")] 740 [text string-append]) 741 @text{@it{Note}: @bf{This is @ul{not} a pipe}.}) 742 -@eval-> 743 "/Note/: *This is _not_ a pipe*." 744 --- 745 (require (for-syntax scheme/base)) 746 (let-syntax ([foo 747 (lambda (stx) 748 (let ([p (syntax-property stx 'scribble)]) 749 (syntax-case stx () 750 [(_ x ...) 751 (and (pair? p) (eq? (car p) 'form) (even? (cadr p))) 752 (let loop ([n (/ (cadr p) 2)] 753 [as '()] 754 [xs (syntax->list #'(x ...))]) 755 (if (zero? n) 756 #`(list 'foo `#,(reverse as) #,@xs) 757 (loop (sub1 n) 758 (cons #`(#,(car xs) ,#,(cadr xs)) as) 759 (cddr xs))))])))]) 760 @foo[x 1 y (* 2 3)]{blah}) 761 -@eval-> 762 (foo ((x 1) (y 6)) "blah") 763 --- 764 (let-syntax ([verb 765 (lambda (stx) 766 (syntax-case stx () 767 [(_ cmd item ...) 768 #`(cmd 769 #,@(let loop ([items (syntax->list #'(item ...))]) 770 (if (null? items) 771 '() 772 (let* ([fst (car items)] 773 [prop (syntax-property fst 'scribble)] 774 [rst (loop (cdr items))]) 775 (cond [(eq? prop 'indentation) rst] 776 [(not (and (pair? prop) 777 (eq? (car prop) 778 'newline))) 779 (cons fst rst)] 780 [else (cons (datum->syntax 781 fst (cadr prop) fst) 782 rst)])))))]))]) 783 @verb[string-append]{ 784 foo 785 bar 786 }) 787 -@eval-> 788 "foo\n bar" 789 --- 790 ;; -------------------- empty input tests 791 --- 792 793 -@-> 794 795 --- 796 797 -@i-> 798 799 --- 800 801 -\-> 802 803 --- 804 805 -\i-> 806 807 --- 808 809 810 END-OF-TESTS 811 ) 812 813 ;; get a tester function 814 815 (define-namespace-anchor anchor) 816 (define ns (namespace-anchor->namespace anchor)) 817 (define (string->tester name) (eval (string->symbol name) ns)) 818 819 ;; reader utilities 820 821 (define the-name (string->path "inp")) 822 823 (define (read-all str reader [whole? #f]) 824 (define i (open-input-string str the-name)) 825 (if whole? 826 (reader i) 827 (let loop () 828 (let ([x (reader i)]) 829 (if (eof-object? x) '() (cons x (loop))))))) 830 831 (define read/BS (scr:make-at-reader #:command-char #\\ #:syntax? #f)) 832 (define read-syntax/BS (scr:make-at-reader #:command-char #\\ #:syntax? #t)) 833 834 (define read-inside/BS 835 (scr:make-at-reader #:inside? #t #:command-char #\\ #:syntax? #f)) 836 837 ;; tester makers 838 839 (define (x . (mk-reader-test reader) . y) 840 (values (read-all x reader) (read-all y read))) 841 842 (define (x . (mk-inside-reader-test inside-reader) . y) 843 (values (read-all x inside-reader #t) (read-all y read))) 844 845 (define (x . (mk-eval-test syntax-reader) . y) 846 (define r (void)) 847 (for ([x (read-all x (lambda (i) (syntax-reader 'test i)))]) 848 (set! r (call-with-values (lambda () (eval x ns)) list))) 849 (values r (read-all y read))) 850 851 (define (x . (mk-syntax-test syntax-reader) . y) 852 (let ([x (read-all x (lambda (i) (syntax-reader 'test i)))] 853 [y (read-all y read)]) 854 (define (check x y) 855 (cond [(or (equal? x y) (eq? y '_)) #t] 856 [(not (pair? y)) #f] 857 [(eq? 'stx: (car y)) (check-stx x (cdr y))] 858 [(pair? x) (and (check (car x) (car y)) (check (cdr x) (cdr y)))] 859 [(syntax? x) (check (syntax-e x) y)] 860 [else #f])) 861 (define (check-stx x y) 862 (cond [(null? y) #t] 863 [(null? (cdr y)) (check x (car y))] 864 [(check 865 ((case (car y) 866 [(line=) syntax-line] 867 [(column=) syntax-column] 868 [(position=) syntax-position] 869 [(span=) syntax-span] 870 [else (error 'syntax-test "unknown test form: ~.s" (car y))]) 871 x) 872 (cadr y)) 873 (check-stx x (cddr y))] 874 [else #f])) 875 (values #t (check x y)))) 876 877 (define (x . (mk-error-test reader) . y) 878 (define (get-exn-data e) 879 (cons (exn-message e) 880 null #; 881 (append-map (lambda (s) (list (srcloc-line s) (srcloc-column s))) 882 (exn:fail:read-srclocs e)) 883 )) 884 (values (with-handlers ([exn:fail:read? get-exn-data]) 885 (read-all x reader) "no error!") 886 (read-all y read))) 887 888 ;; testers 889 890 (define -@-> (mk-reader-test scr:read)) 891 (define -\\-> (mk-reader-test read/BS)) 892 (define -@i-> (mk-inside-reader-test scr:read-inside)) 893 (define -\\i-> (mk-inside-reader-test read-inside/BS)) 894 (define -@eval-> (mk-eval-test scr:read-syntax)) 895 (define -\\eval-> (mk-eval-test read-syntax/BS)) 896 (define -@syntax-> (mk-syntax-test scr:read-syntax)) 897 (define -\\syntax-> (mk-syntax-test read-syntax/BS)) 898 (define -@error-> (mk-error-test scr:read)) 899 (define -\\error-> (mk-error-test read/BS)) 900 901 (define (make-@+-readtable #:command-readtable [command-readtable (current-readtable)] 902 #:datum-readtable [datum-readtable (current-readtable)]) 903 (make-readtable (scr:make-at-readtable #:command-readtable command-readtable 904 #:datum-readtable datum-readtable) 905 #\+ 'terminating-macro (lambda args 'PLUS))) 906 (define @+-readtable (make-@+-readtable)) 907 (define @c+-readtable (make-@+-readtable #:command-readtable 'dynamic)) 908 (define @d+-readtable (make-@+-readtable #:datum-readtable 'dynamic)) 909 (define @cd+-readtable (make-@+-readtable #:command-readtable 'dynamic 910 #:datum-readtable 'dynamic)) 911 912 (define-syntax-rule (@+checker a b readtable) 913 (equal? (parameterize ([current-readtable readtable]) 914 (read (open-input-string a))) 915 b)) 916 (define-syntax-rule (a . -@+> . b) (@+checker a b @+-readtable)) 917 (define-syntax-rule (a . -@c+> . b) (@+checker a b @c+-readtable)) 918 (define-syntax-rule (a . -@d+> . b) (@+checker a b @d+-readtable)) 919 (define-syntax-rule (a . -@cd+> . b) (@+checker a b @cd+-readtable)) 920 921 ;; running the tests 922 (provide reader-tests) 923 (module+ main (reader-tests)) 924 (define (reader-tests) 925 (define (matching? x y) 926 (cond [(equal? x y) #t] 927 [(pair? x) (and (pair? y) 928 (matching? (car x) (car y)) 929 (matching? (cdr x) (cdr y)))] 930 [(and (regexp? x) (string? y)) (matching? y x)] 931 [(and (string? x) (regexp? y)) (regexp-match? y x)] 932 [(procedure? x) (x y)] 933 [(procedure? y) (y x)] 934 [else #f])) 935 (test do 936 (let* ([ts the-tests] 937 ;; remove all comment lines 938 [ts (regexp-replace* #px"(?m:^;.*\r?\n)" ts "")] 939 ;; split the tests 940 [ts (regexp-split #px"(?m:^)-+(?:$|\r?\n)" ts)]) 941 (parameterize ([port-count-lines-enabled #t]) 942 (for ([t ts] #:unless (regexp-match? #px"^\\s*$" t)) 943 (let ([m (or (regexp-match #px"^(.*)\n\\s*(-\\S+->)\\s*\n(.*)$" 944 t) 945 (regexp-match #px"^(.*\\S)\\s+(-\\S+->)\\s+(\\S.*)$" 946 t))]) 947 (if (not (and m (= 4 (length m)))) 948 (error 'bad-test "~a" t) 949 (let-values ([(x y) 950 ((string->tester (caddr m)) (cadr m) (cadddr m))]) 951 (test #:failure-message 952 (format "bad result in\n ~a\n results:\n ~s != ~s" 953 (regexp-replace* #rx"\n" t "\n ") 954 x y) 955 (matching? x y)))))))) 956 957 ;; Check static versus dynamic readtable for command (dynamic when "c" in the 958 ;; name) and datum (dynamic when "d" in the name) parts: 959 (-@+> "10" 10) 960 (-@+> "(+ @+[+] +)" '(PLUS (+ +) PLUS)) 961 (-@+> "@+[+]" '(+ +)) 962 (-@d+> "@+[+]" '(+ PLUS)) 963 (-@d+> "(+ @+[+])" '(PLUS (+ PLUS))) 964 (-@c+> "@+[+]" '(PLUS +)) 965 (-@c+> "@|+|" 'PLUS) 966 (-@cd+> "@+[+]" '(PLUS PLUS))))