commit af9276c9f41fd7cc867ccd497d07a851720b3b17
parent 8e5dd22426524446fbe7faf9cc0d775c83baf87c
Author: Eli Barzilay <eli@racket-lang.org>
Date: Sun, 7 Jun 2009 21:42:38 +0000
* Reorganize the scribble tests to separate files
* Finally moved the scribble reader tests with the rest so it can run
with the nightly build.
svn: r15112
original commit: dd68b710ae1ea2d255b48b793020d1b38c0f9491
Diffstat:
4 files changed, 875 insertions(+), 146 deletions(-)
diff --git a/collects/tests/scribble/collect.ss b/collects/tests/scribble/collect.ss
@@ -0,0 +1,82 @@
+#lang scheme/base
+
+(require tests/eli-tester scribble/text/syntax-utils)
+
+(provide begin/collect-tests)
+
+(define (begin/collect-tests)
+ (test
+
+ ;; begin/collect scope etc
+ (begin/collect 1) => 1
+ (begin/collect 1 2 3) => '(1 2 3)
+ (begin/collect) => '()
+ (begin/collect (define x 1) x) => 1
+ (begin/collect (define x 1)) => '()
+ (begin/collect (define x 1) x x x) => '(1 1 1)
+ (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2)
+ (begin/collect (define x 1) x (define y 2) y) => '(1 2)
+ (begin/collect (define x 1) x (define y 2)) => '(1)
+ (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2)
+ (begin/collect (define x 1) x (define x 2) x) => '(1 2)
+ (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2)
+ (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1)
+ (begin/collect (define x 1) x (define y 2) x) => '(1 1)
+ (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1)
+ (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1)
+ (begin/collect (define (x) y) (define y 1) (x) (x)
+ (define (x) y) (define y 2) (x) (x))
+ => '(1 1 2 2)
+ (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x)
+ => '(1 1)
+ (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x)
+ => '(1 2)
+ (begin/collect (define-syntax-rule (DEF x y) (define x y))
+ (DEF x 1) x x
+ (DEF x 2) x x)
+ => '(1 1 2 2)
+ (begin/collect (define (x) y)
+ (define-syntax-rule (DEF x y) (define x y))
+ (DEF y 1) (x) (x)
+ (DEF y 2) (x) (x))
+ => '(1 1 1 1)
+ (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1)
+ (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2)
+ (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1)
+ (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2)
+ (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y))
+ => '(1 1 2 2)
+ (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x)))
+ => '(1 1 2 2 1)
+ (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y))
+ => '(1 1 1 2 2)
+ (begin/collect (begin (define (x) y)
+ (define-syntax-rule (DEF x y) (define x y))
+ (define y 2))
+ (x) (x))
+ => '(2 2)
+ (begin/collect (define (x) y)
+ (begin (define-syntax-rule (DEF x y) (define x y))
+ (define y 2))
+ (x) (x))
+ => '(2 2)
+ (begin/collect (define (x) y)
+ (define-syntax-rule (DEF x y) (define x y))
+ (begin (define y 2))
+ (x) (x))
+ => '(2 2)
+ (begin/collect (begin (begin (begin (define (x) y))
+ (begin (define-syntax-rule (DEF x y)
+ (define x y))))
+ (begin (begin (define y 2))
+ (begin (x)))
+ (begin (x))))
+ => '(2 2)
+ (begin/collect 1
+ (define (f x #:< [< "<"] #:> [> ">"]) (list < x >))
+ (f 1)
+ (f #:< "[" 2)
+ (f 3 #:> "]" #:< "["))
+ => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]"))
+
+ ))
diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss
@@ -1,149 +1,7 @@
#lang scheme/base
-(require tests/eli-tester scribble/text/syntax-utils
- scheme/runtime-path scheme/port scheme/sandbox
- (prefix-in doc: (lib "scribblings/scribble/preprocessor.scrbl")))
+(require tests/eli-tester "reader.ss" "preprocessor.ss" "collect.ss")
-(define-runtime-path text-dir "text")
-(define-runtime-path this-dir ".")
-
-(define (tests)
- (begin/collect-tests)
- (preprocessor-tests))
-
-(define (begin/collect-tests)
- (test
-
- ;; begin/collect scope etc
- (begin/collect 1) => 1
- (begin/collect 1 2 3) => '(1 2 3)
- (begin/collect) => '()
- (begin/collect (define x 1) x) => 1
- (begin/collect (define x 1)) => '()
- (begin/collect (define x 1) x x x) => '(1 1 1)
- (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2)
- (begin/collect (define x 1) x (define y 2) y) => '(1 2)
- (begin/collect (define x 1) x (define y 2)) => '(1)
- (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2)
- (begin/collect (define x 1) x (define x 2) x) => '(1 2)
- (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2)
- (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1)
- (begin/collect (define x 1) x (define y 2) x) => '(1 1)
- (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1)
- (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1)
- (begin/collect (define (x) y) (define y 1) (x) (x)
- (define (x) y) (define y 2) (x) (x))
- => '(1 1 2 2)
- (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x)
- => '(1 1)
- (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x)
- => '(1 2)
- (begin/collect (define-syntax-rule (DEF x y) (define x y))
- (DEF x 1) x x
- (DEF x 2) x x)
- => '(1 1 2 2)
- (begin/collect (define (x) y)
- (define-syntax-rule (DEF x y) (define x y))
- (DEF y 1) (x) (x)
- (DEF y 2) (x) (x))
- => '(1 1 1 1)
- (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1)
- (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2)
- (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1)
- (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2)
- (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y))
- => '(1 1 2 2)
- (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x)))
- => '(1 1 2 2 1)
- (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y))
- => '(1 1 1 2 2)
- (begin/collect (begin (define (x) y)
- (define-syntax-rule (DEF x y) (define x y))
- (define y 2))
- (x) (x))
- => '(2 2)
- (begin/collect (define (x) y)
- (begin (define-syntax-rule (DEF x y) (define x y))
- (define y 2))
- (x) (x))
- => '(2 2)
- (begin/collect (define (x) y)
- (define-syntax-rule (DEF x y) (define x y))
- (begin (define y 2))
- (x) (x))
- => '(2 2)
- (begin/collect (begin (begin (begin (define (x) y))
- (begin (define-syntax-rule (DEF x y)
- (define x y))))
- (begin (begin (define y 2))
- (begin (x)))
- (begin (x))))
- => '(2 2)
- (begin/collect 1
- (define (f x #:< [< "<"] #:> [> ">"]) (list < x >))
- (f 1)
- (f #:< "[" 2)
- (f 3 #:> "]" #:< "["))
- => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]"))
-
- ))
-
-(define (preprocessor-tests)
- ;; (sample-file-tests)
- (in-documentation-tests))
-
-(define (sample-file-tests)
- (parameterize ([current-directory text-dir])
- (for ([ifile (map path->string (directory-list))]
- #:when (and (file-exists? ifile)
- (regexp-match? #rx"^i[0-9]+\\.ss$" ifile)))
- (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt"))
- (define expected (call-with-input-file ofile
- (lambda (i) (read-bytes (file-size ofile) i))))
- (define o (open-output-bytes))
- (parameterize ([current-output-port o])
- (dynamic-require (path->complete-path ifile) #f))
- (test (get-output-bytes o) => expected))))
-
-(define (in-documentation-tests)
- (define (text-test line in-text out-text more)
- (define-values (i o) (make-pipe 512))
- (define-values (expected len-to-read)
- (let ([m (regexp-match-positions #rx"\n\\.\\.\\.$" out-text)])
- (if m
- (values (substring out-text 0 (caar m)) (caar m))
- (values out-text #f))))
- ;; test with name indicating the source
- (define-syntax-rule (t . stuff)
- (test ;#:failure-message
- ;(format "preprocessor test failure at line ~s" line)
- . stuff))
- (parameterize ([current-directory this-dir]
- [sandbox-output o]
- [sandbox-error-output current-output-port])
- (define exn #f)
- (define thd #f)
- (define (run)
- ;; only need to evaluate the module, so we have its output; but do that
- ;; in a thread, since we might want to look at just a prefix of an
- ;; infinite output
- (with-handlers ([void (lambda (e) (set! exn e))])
- (make-module-evaluator in-text)
- (close-output-port o)))
- (for ([m more])
- (call-with-output-file (car m) #:exists 'truncate
- (lambda (o) (display (cdr m) o))))
- (set! thd (thread run))
- (t (with-limits 2 #f
- (if len-to-read (read-string len-to-read i) (port->string i)))
- => expected)
- (t (begin (kill-thread thd) (cond [exn => raise] [else #t])))
- (for ([m more])
- (when (file-exists? (car m)) (delete-file (car m))))))
- (call-with-trusted-sandbox-configuration
- (lambda ()
- (for ([t (in-list (doc:tests))])
- (begin (apply text-test t))))))
-
-;; run all
-(test do (tests))
+(test do (reader-tests)
+ do (begin/collect-tests)
+ do (preprocessor-tests))
diff --git a/collects/tests/scribble/preprocessor.ss b/collects/tests/scribble/preprocessor.ss
@@ -0,0 +1,66 @@
+#lang scheme/base
+
+(require tests/eli-tester scheme/runtime-path scheme/port scheme/sandbox
+ (prefix-in doc: (lib "scribblings/scribble/preprocessor.scrbl")))
+
+(provide preprocessor-tests)
+
+(define (preprocessor-tests)
+ ;; (sample-file-tests)
+ (in-documentation-tests))
+
+;; unused now
+(define-runtime-path text-dir "text")
+(define (sample-file-tests)
+ (parameterize ([current-directory text-dir])
+ (for ([ifile (map path->string (directory-list))]
+ #:when (and (file-exists? ifile)
+ (regexp-match? #rx"^i[0-9]+\\.ss$" ifile)))
+ (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt"))
+ (define expected (call-with-input-file ofile
+ (lambda (i) (read-bytes (file-size ofile) i))))
+ (define o (open-output-bytes))
+ (parameterize ([current-output-port o])
+ (dynamic-require (path->complete-path ifile) #f))
+ (test (get-output-bytes o) => expected))))
+
+(define-runtime-path this-dir ".")
+(define (in-documentation-tests)
+ (define (text-test line in-text out-text more)
+ (define-values (i o) (make-pipe 512))
+ (define-values (expected len-to-read)
+ (let ([m (regexp-match-positions #rx"\n\\.\\.\\.$" out-text)])
+ (if m
+ (values (substring out-text 0 (caar m)) (caar m))
+ (values out-text #f))))
+ ;; test with name indicating the source
+ (define-syntax-rule (t . stuff)
+ (test ;; #:failure-message
+ ;; (format "preprocessor test failure at line ~s" line)
+ . stuff))
+ (parameterize ([current-directory this-dir]
+ [sandbox-output o]
+ [sandbox-error-output current-output-port])
+ (define exn #f)
+ (define thd #f)
+ (define (run)
+ ;; only need to evaluate the module, so we have its output; but do that
+ ;; in a thread, since we might want to look at just a prefix of an
+ ;; infinite output
+ (with-handlers ([void (lambda (e) (set! exn e))])
+ (make-module-evaluator in-text)
+ (close-output-port o)))
+ (for ([m more])
+ (call-with-output-file (car m) #:exists 'truncate
+ (lambda (o) (display (cdr m) o))))
+ (set! thd (thread run))
+ (t (with-limits 2 #f
+ (if len-to-read (read-string len-to-read i) (port->string i)))
+ => expected)
+ (t (begin (kill-thread thd) (cond [exn => raise] [else #t])))
+ (for ([m more])
+ (when (file-exists? (car m)) (delete-file (car m))))))
+ (call-with-trusted-sandbox-configuration
+ (lambda ()
+ (for ([t (in-list (doc:tests))])
+ (begin (apply text-test t))))))
diff --git a/collects/tests/scribble/reader.ss b/collects/tests/scribble/reader.ss
@@ -0,0 +1,723 @@
+#lang scheme/base
+
+(require tests/eli-tester (prefix-in scr: scribble/reader)
+ (for-syntax scheme/base))
+
+(provide reader-tests)
+
+(define the-tests #<<END-OF-TESTS
+
+;; format:
+;; * a line with only `-'s marks the boundary between tests
+;; * -<token>-> marks a <token> kind of reader test
+;; * lines with semicolon comments flushed at the left column ignored,
+
+---
+;; -------------------- simple uses, test identifiers
+---
+@foo -@-> foo
+---
+@foo{} -@-> (foo)
+---
+@foo[] -@-> (foo)
+---
+@foo[]{} -@-> (foo)
+---
+foo@ -@-> foo@
+---
+fo@o -@-> fo@o
+---
+\@foo -@-> @foo
+---
+|@foo| -@-> @foo
+---
+@foo@bar -@-> foo bar
+---
+@foo@bar. -@-> foo bar.
+---
+@foo@bar: -@-> foo bar:
+---
+@foo@bar; -@-> foo bar
+---
+@foo[]@bar{} -@-> (foo) (bar)
+---
+@foo{foo@|bar|.}
+-@->
+(foo "foo" bar ".")
+---
+@foo{foo@bar;}
+-@->
+(foo "foo" bar ";")
+---
+(define |@foo| '\@bar@baz) -@-> (define @foo '@bar@baz)
+---
+@foo{foo@2.}
+-@->
+(foo "foo" 2.0)
+---
+;; -------------------- simple args and texts
+---
+@foo{bar} -@-> (foo "bar")
+---
+@foo[]{bar} -@-> (foo "bar")
+---
+@foo[bar] -@-> (foo bar)
+---
+@foo[bar]{} -@-> (foo bar)
+---
+@foo[bar][baz] -@-> (foo bar) (baz)
+---
+@foo[bar]{baz} -@-> (foo bar "baz")
+---
+@foo[bar]{baz}[blah] -@-> (foo bar "baz") (blah)
+---
+@foo[bar]{baz}@foo[blah] -@-> (foo bar "baz") (foo blah)
+---
+@foo[#:x y]{bar} -@-> (foo #:x y "bar")
+---
+@foo[1 (* 2 3)]{bar} -@-> (foo 1 (* 2 3) "bar")
+---
+@foo[@bar{...}]{blah}
+-@->
+(foo (bar "...") "blah")
+---
+;; -------------------- no exprs or text
+---
+@{} -@-> ()
+---
+@[] -@-> ()
+---
+@{foo} -@-> ("foo")
+---
+@[foo] -@-> (foo)
+---
+@|{blah}| -@-> ("blah")
+---
+;; -------------------- newlines and spaces in text
+---
+@foo{bar baz} -@-> (foo "bar baz")
+---
+@foo{bar baz} -@-> (foo "bar baz")
+---
+@foo{ bar } -@-> (foo " bar ")
+---
+@foo{ bar } -@-> (foo " bar ")
+---
+@foo{ } -@-> (foo " ")
+---
+@foo{ } -@-> (foo " ")
+---
+@foo[1]{bar baz} -@-> (foo 1 "bar baz")
+---
+@foo[1]{bar baz} -@-> (foo 1 "bar baz")
+---
+@foo[1]{ bar } -@-> (foo 1 " bar ")
+---
+@foo[1]{ bar } -@-> (foo 1 " bar ")
+---
+@foo[1]{ } -@-> (foo 1 " ")
+---
+@foo[1]{ } -@-> (foo 1 " ")
+---
+@foo{bar baz
+ blah}
+-@->
+(foo "bar baz" "\n" "blah")
+---
+@foo[1]{bar baz
+ blah}
+-@->
+(foo 1 "bar baz" "\n" "blah")
+---
+@foo{bar baz
+
+ blah}
+-@->
+(foo "bar baz" "\n" "\n" "blah")
+---
+@foo{bar baz
+
+
+ blah}
+-@->
+(foo "bar baz" "\n" "\n" "\n" "blah")
+---
+@foo{bar
+ }
+-@->
+(foo "bar")
+---
+@foo{
+ bar}
+-@->
+(foo "bar")
+---
+@foo{
+ bar
+ }
+-@->
+(foo "bar")
+---
+@foo{
+
+ bar
+ }
+-@->
+(foo "\n" "bar")
+---
+@foo{
+ bar
+
+ }
+-@->
+(foo "bar" "\n")
+---
+@foo{
+
+ bar
+
+ }
+-@->
+(foo "\n" "bar" "\n")
+---
+@foo{
+ }
+-@->
+(foo "\n")
+---
+@foo{
+
+ }
+-@->
+(foo "\n" "\n")
+---
+@foo{
+
+
+ }
+-@->
+(foo "\n" "\n" "\n")
+---
+;; -------------------- nested forms
+---
+@foo{@bar} -@-> (foo bar)
+---
+@foo{@bar{}} -@-> (foo (bar))
+---
+@foo{111@bar{222}333} -@-> (foo "111" (bar "222") "333")
+---
+@foo{111@bar[222]333} -@-> (foo "111" (bar 222) "333")
+---
+@foo[111 @bar{222} 333] -@-> (foo 111 (bar "222") 333)
+---
+@foo[111 @bar{222}333] -@-> (foo 111 (bar "222") 333)
+---
+@foo[111 @bar[222]333] -@-> (foo 111 (bar 222) 333)
+---
+@foo[111 @bar 222] -@-> (foo 111 bar 222)
+---
+@foo{111 @bar 222} -@-> (foo "111 " bar " 222")
+---
+@foo{@bar 111} -@-> (foo bar " 111")
+---
+@foo{111 @bar} -@-> (foo "111 " bar)
+---
+@foo{ @bar } -@-> (foo " " bar " ")
+---
+@foo{bar @baz[3]
+ blah}
+-@->
+(foo "bar " (baz 3) "\n" "blah")
+---
+@foo{bar @baz{3}
+ blah}
+-@->
+(foo "bar " (baz "3") "\n" "blah")
+---
+@foo{bar @baz[2 3]{4 5}
+ blah}
+-@->
+(foo "bar " (baz 2 3 "4 5") "\n" "blah")
+---
+@foo{bar @baz[2 3] {4 5}}
+-@->
+(foo "bar " (baz 2 3) " {4 5}")
+---
+;; -------------------- cannot have spaces before args or text
+---
+@foo [bar] -@-> foo (bar)
+---
+@foo {bar} -@-> foo (bar)
+---
+@foo[bar] {baz} -@-> (foo bar) (baz)
+---
+@foo{bar @baz {bleh}} -@-> (foo "bar " baz " {bleh}")
+---
+;; -------------------- expression escapes, operators, currying
+---
+@foo{1 @(+ 2 3) 4} -@-> (foo "1 " (+ 2 3) " 4")
+---
+@(lambda (x) x){blah} -@-> ((lambda (x) x) "blah")
+---
+@(lambda (x) x)[blah] -@-> ((lambda (x) x) blah)
+---
+@foo{bar}{baz} -@-> (foo "bar") (baz)
+---
+@@foo{bar}{baz} -@-> ((foo "bar") "baz")
+---
+@@foo{bar} {baz} -@-> (foo "bar") (baz)
+---
+@@foo{bar}{baz}{} -@-> ((foo "bar") "baz") ()
+---
+@@@foo{bar}{baz}{} -@-> (((foo "bar") "baz"))
+---
+@@@foo[]{}[][] -@-> (((foo)))
+---
+@@@foo[]{}[][][] -@-> (((foo))) ()
+---
+@foo{foo@|3|.}
+-@->
+(foo "foo" 3 ".")
+---
+@foo{foo@|(f 1)|{bar}}
+-@->
+(foo "foo" (f 1) "{bar}")
+---
+@foo{foo@|bar|[1]{baz}}
+-@->
+(foo "foo" bar "[1]{baz}")
+---
+;; -------------------- pulling punctuations outside
+---
+@'foo -@-> 'foo
+---
+@'foo[1 2] -@-> '(foo 1 2)
+---
+@'foo{bar} -@-> '(foo "bar")
+---
+@`foo{bar} -@-> `(foo "bar")
+---
+@,foo{bar} -@-> ,(foo "bar")
+---
+@,@foo{bar} -@-> ,@(foo "bar")
+---
+@`',foo{bar} -@-> `',(foo "bar")
+---
+@`',`',foo{bar} -@-> `',`',(foo "bar")
+---
+@``'',,foo{bar} -@-> ``'',,(foo "bar")
+---
+@`',@foo{bar} -@-> `',@(foo "bar")
+---
+@`',@`',@foo{bar} -@-> `',@`',@(foo "bar")
+---
+@``'',@,@foo{bar} -@-> ``'',@,@(foo "bar")
+---
+@``'',,,@,@foo{bar} -@-> ``'',,,@,@(foo "bar")
+---
+@#'foo{bar} -@-> #'(foo "bar")
+---
+@#`foo{bar} -@-> #`(foo "bar")
+---
+@#,foo{bar} -@-> #,(foo "bar")
+---
+@#''foo{bar} -@-> #''(foo "bar")
+---
+@#`'#,foo{bar} -@-> #`'#,(foo "bar")
+---
+@`foo{123 @,bar{456} 789}
+-@->
+`(foo "123 " ,(bar "456") " 789")
+---
+@`(unquote foo){blah}
+-@->
+`(,foo "blah")
+---
+;; -------------------- balanced braces are allowed
+---
+@foo{f{o}o} -@-> (foo "f{o}o")
+---
+@foo{{{}}{}} -@-> (foo "{{}}{}")
+---
+@foo{f[o]o} -@-> (foo "f[o]o")
+---
+@foo{[{}]{}} -@-> (foo "[{}]{}")
+---
+;; -------------------- string escapes
+---
+@foo{x@"y"z} -@-> (foo "xyz")
+---
+@foo{A @"}" marks the end}
+-@->
+(foo "A } marks the end")
+---
+@foo{The prefix is: @"@".}
+-@->
+(foo "The prefix is: @.")
+--
+@foo{@"@x{y}" => (x "y")}
+-@->
+(foo "@x{y} => (x \"y\")")
+---
+;; -------------------- alternative delimiters
+---
+@foo|{...}| -@-> (foo "...")
+---
+@foo|{"}" after "{"}| -@-> (foo "\"}\" after \"{\"")
+---
+@foo|{Nesting |{is}| ok}| -@-> (foo "Nesting |{is}| ok")
+---
+@foo|{Nested @form{not}}| -@-> (foo "Nested @form{not}")
+---
+@foo|{Nested |@form|{yes}|}| -@-> (foo "Nested " (form "yes"))
+---
+@foo|{Nested |@form{indep@{end}ence}}|
+-@->
+(foo "Nested " (form "indep" ("end") "ence"))
+---
+@foo|{Nested |@|name|}| -@-> (foo "Nested " name)
+---
+@foo|{With
+ |@bar{multiple}
+ lines.}|
+-@->
+(foo "With" "\n" (bar "multiple") "\n" "lines.")
+---
+@t|{In |@i|{sub|@"@"s}| too}| -@-> (t "In " (i "sub@s") " too")
+---
+@foo|<<<{@x{foo} |@{bar}|.}>>>| -@-> (foo "@x{foo} |@{bar}|.")
+---
+@foo|<<<{@x{foo} |<<<@{bar}|.}>>>| -@-> (foo "@x{foo} " ("bar") "|.")
+---
+@foo|!!{X |!!@b{Y}...}!!| -@-> (foo "X " (b "Y") "...")
+---
+;; -------------------- comments
+---
+(1 2 @; comment
+ 3 4)
+-@->
+(1 2 3 4)
+---
+@foo{bar @; comment
+ baz@;
+ blah}
+-@->
+(foo "bar bazblah")
+---
+@foo{bar @; comment, with space and newline
+
+ baz}
+-@->
+(foo "bar " "\n" "baz")
+---
+@foo{bar @;{a balanced comment} baz}
+-@->
+(foo "bar baz")
+---
+@foo|{bar @;{a non-comment} baz}|
+-@->
+(foo "bar @;{a non-comment} baz")
+---
+@foo|{bar |@;{a balanced comment again} baz}|
+-@->
+(foo "bar baz")
+---
+@foo{First line@;{there is still a
+ newline here;}
+ Second line}
+-@->
+(foo "First line" "\n" "Second line")
+---
+@foo{A long @;
+ single-@;
+ string arg.}
+-@->
+(foo "A long single-string arg.")
+---
+;; -------------------- indentation management
+---
+@foo{ bar
+ baz }
+-@->
+(foo " bar" "\n" "baz ")
+---
+@foo{bar
+}
+-@->
+(foo "bar")
+---
+@foo{
+bar}
+-@->
+(foo "bar")
+---
+@foo{
+ bar
+}
+-@->
+(foo "bar")
+---
+@foo{
+
+ bar
+
+}
+-@->
+(foo "\n" "bar" "\n")
+---
+@foo{
+ bar
+
+ baz
+}
+-@->
+(foo "bar" "\n" "\n" "baz")
+---
+@foo{
+}
+-@->
+(foo "\n")
+---
+@foo{
+ bar
+ baz
+ blah
+}
+-@->
+(foo "bar" "\n" "baz" "\n" "blah")
+---
+@foo{
+ begin
+ x++;
+ end}
+-@->
+(foo "begin" "\n" " " "x++;" "\n" "end")
+---
+@foo{
+ a
+ b
+ c}
+-@->
+(foo " " "a" "\n" " " "b" "\n" "c")
+---
+@foo{bar
+ baz
+ bbb}
+-@->
+(foo "bar" "\n" " " "baz" "\n" "bbb")
+---
+;; requires location tracking
+@foo{ bar
+ baz
+ bbb}
+-@->
+(foo " bar" "\n" " " "baz" "\n" " " "bbb")
+---
+@foo{bar
+ baz
+ bbb}
+-@->
+(foo "bar" "\n" "baz" "\n" "bbb")
+---
+@foo{ bar
+ baz
+ bbb}
+-@->
+(foo " bar" "\n" "baz" "\n" "bbb")
+---
+@foo{ bar
+ baz
+ bbb}
+-@->
+(foo " bar" "\n" "baz" "\n" " " "bbb")
+---
+@text{Some @b{bold
+ text}, and
+ more text.}
+-@->
+(text "Some " (b "bold" "\n" "text") ", and" "\n" "more text.")
+---
+@code{
+ begin
+ i = 1, r = 1
+ @bold{while i < n do
+ r *= i++
+ done}
+ end
+}
+-@->
+(code "begin" "\n"
+ " " "i = 1, r = 1" "\n"
+ " " (bold "while i < n do" "\n"
+ " " "r *= i++" "\n"
+ "done") "\n"
+ "end")
+---
+@foo{
+ @|| bar @||
+ @|| baz}
+-@->
+(foo " bar " "\n" " baz")
+---
+@foo{bar
+ @|baz| bbb
+ @|x1 x2| x3 x4
+ @|| waaaah
+ }
+-@->
+(foo "bar" "\n" baz " bbb" "\n" x1 x2 " x3 x4" "\n" " waaaah")
+---
+@foo{x1
+ x2@;
+ y2
+ x3@;{
+ ;}y3
+ x4@|
+ |y4
+ x5}
+-@->
+(foo "x1" "\n" "x2y2" "\n" "x3y3" "\n" "x4" "y4" "\n" "x5")
+---
+;; -------------------- ||-quotes for artificial separators and multi-exprs
+---
+@foo{x@||z} -@-> (foo "x" "z")
+---
+@foo{x@|"y"|z} -@-> (foo "x" "y" "z")
+---
+@foo{x@|"y" "z"|} -@-> (foo "x" "y" "z")
+---
+@foo{x@|1 (+ 2 3) 4|y} -@-> (foo "x" 1 (+ 2 3) 4 "y")
+---
+@foo{x@|*
+ *|y}
+-@->
+(foo "x" * * "y")
+---
+@foo{Alice@||Bob@|
+ |Carol}
+-@->
+(foo "Alice" "Bob" "Carol")
+---
+@foo{Alice@||Bob@| x
+ |Carol}
+-@->
+(foo "Alice" "Bob" x "Carol")
+---
+@foo{@||
+ bar
+ @||}
+-@->
+(foo "\n" "bar" "\n")
+---
+;; -------------------- some code test
+---
+@string-append{1 @(number->string (+ 2 3)) 4} -@e-> "1 5 4"
+---
+(let* ([formatter (lambda (fmt)
+ (lambda args (format fmt (apply string-append args))))]
+ [bf (formatter "*~a*")]
+ [it (formatter "/~a/")]
+ [ul (formatter "_~a_")]
+ [text string-append])
+ @text{@it{Note}: @bf{This is @ul{not} a pipe}.})
+-@e->
+"/Note/: *This is _not_ a pipe*."
+---
+(let ([nl (car @'{
+ })]
+ [o (open-output-string)])
+ (for-each (lambda (x) (display (if (eq? x nl) "\n... " x) o))
+ @`{foo
+ @,@(list "bar" "\n" "baz")
+ blah})
+ (newline o)
+ (get-output-string o))
+-@e->
+"foo\n... bar\nbaz\n... blah\n"
+---
+(let-syntax ([foo
+ (lambda (stx)
+ (let ([p (syntax-property stx 'scribble)])
+ (syntax-case stx ()
+ [(_ x ...)
+ (and (pair? p) (eq? (car p) 'form) (even? (cadr p)))
+ (let loop ([n (/ (cadr p) 2)]
+ [as '()]
+ [xs (syntax->list #'(x ...))])
+ (if (zero? n)
+ #`(list 'foo `#,(reverse as) #,@xs)
+ (loop (sub1 n)
+ (cons #`(#,(car xs) ,#,(cadr xs)) as)
+ (cddr xs))))])))])
+ @foo[x 1 y (* 2 3)]{blah})
+-@e->
+(foo ((x 1) (y 6)) "blah")
+---
+(let-syntax ([verb
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ cmd item ...)
+ #`(cmd
+ #,@(let loop ([items (syntax->list #'(item ...))])
+ (if (null? items)
+ '()
+ (let* ([fst (car items)]
+ [prop (syntax-property fst 'scribble)]
+ [rst (loop (cdr items))])
+ (cond [(eq? prop 'indentation) rst]
+ [(not (and (pair? prop)
+ (eq? (car prop)
+ 'newline)))
+ (cons fst rst)]
+ [else (cons (datum->syntax
+ fst (cadr prop) fst)
+ rst)])))))]))])
+ @verb[string-append]{
+ foo
+ bar
+ })
+-@e->
+"foo\n bar"
+---
+
+END-OF-TESTS
+)
+
+(define-namespace-anchor anchor)
+(define ns (namespace-anchor->namespace anchor))
+(define (string->tester name) (eval (string->symbol name) ns))
+
+(define (read-all str reader)
+ (define i (open-input-string str))
+ (port-count-lines! i)
+ (let loop ()
+ (let ([x (reader i)])
+ (if (eof-object? x) '() (cons x (loop))))))
+
+(define (x . -@e-> . y)
+ (define r (void))
+ (for ([x (read-all x (lambda (i) (scr:read-syntax 'test i)))])
+ (set! r (call-with-values (lambda () (eval x ns)) list)))
+ (values r (read-all y read)))
+
+(define (x . -@-> . y)
+ (values (read-all x scr:read) (read-all y read)))
+
+(define (reader-tests)
+ (test do
+ (let* ([ts the-tests]
+ [ts (regexp-replace* #px"(?m:^;.*\r?\n)" ts "")]
+ [ts (regexp-replace #px"^\\s+" ts "")]
+ [ts (regexp-replace #px"\\s+$" ts "")]
+ [ts (regexp-split #px"\\s*(?:^|\r?\n)-+(?:$|\r?\n)\\s*" ts)])
+ (for ([t ts] #:when (not (equal? "" t)))
+ (let ([m (regexp-match #px"^(.*\\S)\\s+(-\\S+->)\\s+(\\S.*)$" t)])
+ (if (not (and m (= 4 (length m))))
+ (error 'bad-test "~a" t)
+ (let-values ([(x y)
+ ((string->tester (caddr m)) (cadr m) (cadddr m))])
+ (test #:failure-message
+ (format "bad result in\n ~a\n results:\n ~s != ~s"
+ (regexp-replace* #rx"\n" t "\n ")
+ x y)
+ (equal? x y)))))))))
