From af9276c9f41fd7cc867ccd497d07a851720b3b17 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 7 Jun 2009 21:42:38 +0000 Subject: [PATCH] * 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 --- collects/tests/scribble/collect.ss | 82 +++ collects/tests/scribble/main.ss | 150 +---- collects/tests/scribble/preprocessor.ss | 66 +++ collects/tests/scribble/reader.ss | 723 ++++++++++++++++++++++++ 4 files changed, 875 insertions(+), 146 deletions(-) create mode 100644 collects/tests/scribble/collect.ss create mode 100644 collects/tests/scribble/preprocessor.ss create mode 100644 collects/tests/scribble/reader.ss diff --git a/collects/tests/scribble/collect.ss b/collects/tests/scribble/collect.ss new file mode 100644 index 00000000..ef4b2333 --- /dev/null +++ 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 index 8ef6019d..f94a956a 100644 --- 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 new file mode 100644 index 00000000..84eae3e0 --- /dev/null +++ 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 new file mode 100644 index 00000000..c278478e --- /dev/null +++ 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 #<-> marks a 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)))))))))