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)]
+      [(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)
-                   (if (list? x)
                      (for ([x (in-list x)]) (loop x))
-                     (let ploop ([x x])
+                     (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))
-                       (if (pair? x)
+                   (begin (loop (car x)) (loop (cdr x))))]
-                         (begin (loop (car x)) (ploop (cdr x)))
-                         (loop x))))
-                   (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
       ;; 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 strs1 (split in-text))
-  (define strs2 (split 2nd))
+  (define strs2 (split out-text))
   (define strsm (map (compose split cdr) more))
   (define (str->elts 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))))))
+          (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 (small-attr attr)
-  (define box1 (make-box strs1))
+    (make-with-attributes attr '([style . "font-size: 82%;"])))
-  (define box2 (make-box strs2))
+  (define (make-box strs)
-  (define boxm (map make-box strsm))
+    (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])
+   (make-table (make-with-attributes
-     (cons (list (as-flow indent) (as-flow box1))
+                '([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 (textsample line in-text out-text more)
-  (define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd 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,13 +173,14 @@
 (define-syntax (example stx)
   (define sep-rx  #px"^---[*]{3}---(?: +(.*))?$")
   (define file-rx #rx"^[a-z0-9_.+-]+$")
+  (define-values (body hidden?)
     (syntax-case stx ()
-    [(_ x ...)
+      [(_ #:hidden x ...) (values #'(x ...) #t)]
-     (let loop ([xs #'(x ...)] [text '(#f)] [texts '()])
+      [(_          x ...) (values #'(x ...) #f)]))
+  (let loop ([xs body] [text '(#f)] [texts '()])
     (syntax-case xs ()
       [("\n" sep "\n" . xs)
-          (and (string? (syntax-e #'sep))
+       (and (string? (syntax-e #'sep)) (regexp-match? sep-rx (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)))
@@ -186,12 +196,14 @@
               (raise-syntax-error
                'example "need at least an input and an output block" stx))
             (with-syntax ([line  line]
-                             [((i/o ...) ...) (map cdr i/o)]
+                          [((in ...) (out ...)) (map cdr i/o)]
                           [((file text ...) ...) files]
                           [add-to-tests (cadr tests-ids)])
-                 (syntax/loc stx
+              (quasisyntax/loc stx
-                   (let ([t (list line (string-append i/o ...) ...
+                (let* ([in-text  (string-append in ...)]
-                                  (cons file (string-append text ...)) ...)])
+                       [out-text (string-append out ...)]
-                     (add-to-tests t)
+                       [more (list (cons file (string-append text ...)) ...)])
-                     (apply textsample t)))))]
+                  (add-to-tests (list line in-text out-text more))
-         [_ (raise-syntax-error #f "no separator found in example text")]))]))
+                  #,(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,11 +1,17 @@
 #lang scheme/base
 
-(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path
+(require tests/eli-tester scribble/text/syntax-utils
-         scheme/sandbox (lib "scribblings/scribble/preprocessor.scrbl"))
+         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 ".")
 
+(define (tests)
+  (begin/collect-tests)
+  (preprocessor-tests))
+
+(define (begin/collect-tests)
   (test
 
    ;; begin/collect scope etc
@@ -80,7 +86,13 @@
                   (f 3 #:> "]" #:< "["))
    => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]"))
 
- ;; preprocessor tests
+   ))
+
+(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)
@@ -91,17 +103,45 @@
       (define o (open-output-bytes))
       (parameterize ([current-output-port o])
         (dynamic-require (path->complete-path ifile) #f))
-     (test (get-output-bytes o) => expected)))
+      (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)))))
 
- )
+(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))