Finished the docs+tests, added some minor utilities.

svn: r14199

original commit: 1db2b65978b9f2330d2de01f1caaef26f3f2cd3a

collects/scribble/text/output.ss

@@ -2,7 +2,7 @@
 
 (require scheme/promise)
 
-(provide output splice verbatim unverbatim flush prefix)
+(provide output)
 
 ;; Outputs some value, for the preprocessor langauge.
 ;;
@@ -68,7 +68,7 @@
   ;; the basic printing unit: strings
   (define (output-string x)
     (define pfx (mcar pfxs))
-    (if (not pfx) ; vervatim mode?
+    (if (not pfx) ; verbatim mode?
       (write-string x p)
       (let ([len (string-length x)]
             [nls (regexp-match-positions* #rx"\n" x)])
@@ -105,16 +105,13 @@
       ;; one, then output the contents recursively (no need to change the
       ;; state, since we pass the values in the loop, and we'd need to restore
       ;; it afterwards anyway)
-      [(pair? x) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
-                        [npfx (pfx+col (pfx+ pfx lpfx))])
-                   (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
-                   (if (list? x)
+      [(pair? x) (if (list? x)
+                   (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
+                          [npfx (pfx+col (pfx+ pfx lpfx))])
+                     (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
                      (for ([x (in-list x)]) (loop x))
-                     (let ploop ([x x])
-                       (if (pair? x)
-                         (begin (loop (car x)) (ploop (cdr x)))
-                         (loop x))))
-                   (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
+                     (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))
+                   (begin (loop (car x)) (loop (cdr x))))]
       ;; delayed values
       [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
       [(promise? x) (loop (force x))]
@@ -172,6 +169,10 @@
             (set! last (cons p s))
             s)))))
 
+;; special constructs
+
+(provide splice verbatim unverbatim flush prefix)
+
 (define-struct special (flag contents))
 
 (define (splice     . contents) (make-special 'splice     contents))
@@ -187,3 +188,25 @@
           (let ([spaces (make-string n #\space)])
             (if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces))
             spaces)))))
+
+;; Convenient utilities
+
+(provide add-newlines)
+(define (add-newlines list #:sep [sep "\n"])
+  (define r
+    (let loop ([list list])
+      (if (null? list)
+        null
+        (let ([1st (car list)])
+          (if (or (not 1st) (void? 1st))
+            (loop (cdr list))
+            (list* sep 1st (loop (cdr list))))))))
+  (if (null? r) r (cdr r)))
+
+(provide split-lines)
+(define (split-lines list)
+  (let loop ([list list] [cur '()] [r '()])
+    (cond
+      [(null? list) (reverse (cons (reverse cur) r))]
+      [(equal? "\n" (car list)) (loop (cdr list) '() (cons (reverse cur) r))]
+      [else (loop (cdr list) (cons (car list) cur) r)])))

collects/scribblings/scribble/utils.ss

@@ -102,25 +102,27 @@
 
 (require scheme/list (for-syntax scheme/base scheme/list))
 
-(define max-textsample-width 35)
+(define max-textsample-width 45)
 
-(define (textsample-verbatim-boxes line 1st 2nd more)
+(define (textsample-verbatim-boxes line in-text out-text more)
   (define (split str) (regexp-split #rx"\n" str))
-  (define strs1 (split 1st))
-  (define strs2 (split 2nd))
+  (define strs1 (split in-text))
+  (define strs2 (split out-text))
   (define strsm (map (compose split cdr) more))
   (define (str->elts str)
-    (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
-      (if spaces
-        (list* (substring str 0 (caar spaces))
-               (hspace (- (cdar spaces) (caar spaces)))
-               (str->elts (substring str (cdar spaces))))
-        (list (make-element 'tt (list str))))))
+    (if (equal? str "")
+      (list (make-element 'newline (list "")))
+      (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
+        (if spaces
+          (list* (substring str 0 (caar spaces))
+                 (hspace (- (cdar spaces) (caar spaces)))
+                 (str->elts (substring str (cdar spaces))))
+          (list (make-element 'tt (list str)))))))
   (define (make-line str) (list (as-flow (make-element 'tt (str->elts str)))))
-  (define (make-box strs) (make-table 'boxed (map make-line strs)))
-  (define box1 (make-box strs1))
-  (define box2 (make-box strs2))
-  (define boxm (map make-box strsm))
+  (define (small-attr attr)
+    (make-with-attributes attr '([style . "font-size: 82%;"])))
+  (define (make-box strs)
+    (make-table (small-attr 'boxed) (map make-line strs)))
   (define filenames (map car more))
   (define indent (let ([d (- max-textsample-width
                              (for*/fold ([m 0])
@@ -130,20 +132,27 @@
                    (if (negative? d)
                      (error 'textsample-verbatim-boxes
                             "left box too wide for sample at line ~s" line)
-                     (hspace d))))
+                     (make-element 'tt (list (hspace d))))))
+  ;; Note: the font-size property is reset for every table, so we need it
+  ;; everywhere there's text, and they don't accumulate for nested tables
   (values
-   (make-table '([alignment right left] [valignment top top])
-     (cons (list (as-flow indent) (as-flow box1))
+   (make-table (make-with-attributes
+                '([alignment right left] [valignment top top])
+                '())
+     (cons (list (as-flow (make-table (small-attr #f)
+                                      (list (list (as-flow indent)))))
+                 (as-flow (make-box strs1)))
            (map (lambda (file strs)
                   (let* ([file (make-element 'tt (list file ":" 'nbsp))]
                          [file (list (make-element 'italic (list file)))])
                     (list (as-flow (make-element '(bg-color 232 232 255) file))
                           (as-flow (make-box strs)))))
                 filenames strsm)))
-   box2))
+   (make-box strs2)))
 
-(define (textsample line 1st 2nd . more)
-  (define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd more))
+(define (textsample line in-text out-text more)
+  (define-values (box1 box2)
+    (textsample-verbatim-boxes line in-text out-text more))
   (make-table '([alignment left left left] [valignment center center center])
     (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2)))))
 
@@ -164,34 +173,37 @@
 (define-syntax (example stx)
   (define sep-rx  #px"^---[*]{3}---(?: +(.*))?$")
   (define file-rx #rx"^[a-z0-9_.+-]+$")
-  (syntax-case stx ()
-    [(_ x ...)
-     (let loop ([xs #'(x ...)] [text '(#f)] [texts '()])
-       (syntax-case xs ()
-         [("\n" sep "\n" . xs)
-          (and (string? (syntax-e #'sep))
-               (regexp-match? sep-rx (syntax-e #'sep)))
-          (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr]
-                         [else #f])])
-            (if (and m (not (regexp-match? file-rx m)))
-              (raise-syntax-error #f "bad filename specified" stx #'sep)
-              (loop #'xs
-                    (list (and m (datum->syntax #'sep m #'sep #'sep)))
-                    (cons (reverse text) texts))))]
-         [(x . xs) (loop #'xs (cons #'x text) texts)]
-         [() (let ([texts (reverse (cons (reverse text) texts))]
-                   [line  (syntax-line stx)])
-               (define-values (files i/o) (partition car texts))
-               (unless ((length i/o) . = . 2)
-                 (raise-syntax-error
-                  'example "need at least an input and an output block" stx))
-               (with-syntax ([line  line]
-                             [((i/o ...) ...) (map cdr i/o)]
-                             [((file text ...) ...) files]
-                             [add-to-tests (cadr tests-ids)])
-                 (syntax/loc stx
-                   (let ([t (list line (string-append i/o ...) ...
-                                  (cons file (string-append text ...)) ...)])
-                     (add-to-tests t)
-                     (apply textsample t)))))]
-         [_ (raise-syntax-error #f "no separator found in example text")]))]))
+  (define-values (body hidden?)
+    (syntax-case stx ()
+      [(_ #:hidden x ...) (values #'(x ...) #t)]
+      [(_          x ...) (values #'(x ...) #f)]))
+  (let loop ([xs body] [text '(#f)] [texts '()])
+    (syntax-case xs ()
+      [("\n" sep "\n" . xs)
+       (and (string? (syntax-e #'sep)) (regexp-match? sep-rx (syntax-e #'sep)))
+       (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr]
+                      [else #f])])
+         (if (and m (not (regexp-match? file-rx m)))
+           (raise-syntax-error #f "bad filename specified" stx #'sep)
+           (loop #'xs
+                 (list (and m (datum->syntax #'sep m #'sep #'sep)))
+                 (cons (reverse text) texts))))]
+      [(x . xs) (loop #'xs (cons #'x text) texts)]
+      [() (let ([texts (reverse (cons (reverse text) texts))]
+                [line  (syntax-line stx)])
+            (define-values (files i/o) (partition car texts))
+            (unless ((length i/o) . = . 2)
+              (raise-syntax-error
+               'example "need at least an input and an output block" stx))
+            (with-syntax ([line  line]
+                          [((in ...) (out ...)) (map cdr i/o)]
+                          [((file text ...) ...) files]
+                          [add-to-tests (cadr tests-ids)])
+              (quasisyntax/loc stx
+                (let* ([in-text  (string-append in ...)]
+                       [out-text (string-append out ...)]
+                       [more (list (cons file (string-append text ...)) ...)])
+                  (add-to-tests (list line in-text out-text more))
+                  #,(if hidden? #'""
+                        #'(textsample line in-text out-text more))))))]
+      [_ (raise-syntax-error #f "no separator found in example text")])))

collects/tests/scribble/main.ss

@@ -1,107 +1,147 @@
 #lang scheme/base
 
-(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path
-         scheme/sandbox (lib "scribblings/scribble/preprocessor.scrbl"))
+(require tests/eli-tester scribble/text/syntax-utils
+         scheme/runtime-path scheme/port scheme/sandbox
+         (prefix-in doc: (lib "scribblings/scribble/preprocessor.scrbl")))
 
 (define-runtime-path text-dir "text")
 (define-runtime-path this-dir ".")
 
-(test
+(define (tests)
+  (begin/collect-tests)
+  (preprocessor-tests))
 
- ;; 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 (begin/collect-tests)
+  (test
 
- ;; preprocessor 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)))
- ;; preprocessor tests that are part of the documentation
- (parameterize ([current-directory this-dir]
-                [sandbox-output 'string]
-                [sandbox-error-output current-output-port])
-   (define (text-test line in out . more)
-     (define e (make-module-evaluator in))
-     (test
-      #:failure-message (format "preprocessor test failure at line ~s" line)
-      (equal? (get-output e) out)))
-   (call-with-trusted-sandbox-configuration
-    (lambda () (for ([t (in-list (tests))]) (apply text-test t)))))
+   ;; 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 1 #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])))))
+  (call-with-trusted-sandbox-configuration
+    (lambda ()
+      (for ([t (in-list (doc:tests))])
+        (begin (apply text-test t))))))
+
+;; run all
+(test do (tests))