Finished the docs+tests, added some minor utilities.

svn: r14199

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,12 +1,18 @@
 #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 ".")
 
-(test
+(define (tests)
+  (begin/collect-tests)
+  (preprocessor-tests))
+
+(define (begin/collect-tests)
+  (test
 
    ;; begin/collect scope etc
    (begin/collect 1) => 1
@@ -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))

collects/tests/scribble/text/i01.ss

@@ -1,3 +0,0 @@
-#lang scribble/text
-
-foo

collects/tests/scribble/text/i02.ss

@@ -1,25 +0,0 @@
-#lang scribble/text
-
-@define[name]{PLT Scheme}
-
-Suggested price list for "@name"
-
-@; test mutual recursion, throwing away inter-definition spaces
-@; <-- this is needed to get only one line of space above
-@(define (items-num)
-   (length items))
-
-@(define average
-   (delay (/ (apply + (map car items)) (length items))))
-
-@(define items
-   (list @list[99]{Home}
-         @list[149]{Professional}
-         @list[349]{Enterprize}))
-
-@(for/list ([i items] [n (in-naturals)])
-   @list{@|n|. @name @cadr[i] edition: $@car[i].99
-         @||})@; <-- also needed
-
-Total: @items-num items
-Average price: $@|average|.99

collects/tests/scribble/text/i03.ss

@@ -1,18 +0,0 @@
-#lang scribble/text
-
----***---
-@(define (angled . body) (list "<" body ">"))
- @(define (shout . body) @angled[(map string-upcase body)])
-  @define[z]{blah}
-
-blah @angled{blah @shout{@z} blah} blah
-
-@(define-syntax-rule @twice[x]
-   (list x ", " x))
-
-@twice{@twice{blah}}
-
-@include{i03a}
-
-@(let ([name "Eli"]) (let ([foo (include "i03b")]) (list foo "\n" foo)))
-Repeating yourself much?

collects/tests/scribble/text/i03a

@@ -1 +0,0 @@
-Warning: blah overdose might be fatal

collects/tests/scribble/text/i03b

@@ -1,12 +0,0 @@
-@(define (foo . xs) (bar xs))
-@(begin (define (isname) @list{is @foo{@name}})
-        (define-syntax-rule (DEF x y) (define x y)))
-@(DEF (bar x) (list z " " x))
-@(define-syntax-rule (BEG x ...) (begin x ...))
-@(BEG (define z "zee"))
-
-My name @isname
-@DEF[x]{Foo!}
-
-  ... and to that I say "@x", I think.
-

collects/tests/scribble/text/i04.ss

@@ -1,24 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@; demonstrates how indentation is preserved inside lists
-
-begin
-  a
-  b
-  @list{c
-        d
-        @list{e
-                f
-              g}
-        h
-          i
-          @list{j
-                  k
-                l}
-          m
-        n
-        o}
-  p
-  q
-end

collects/tests/scribble/text/i05.ss

@@ -1,30 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@(define (((if . c) . t) . e)
-   @list{
-     if (@c)
-       @t
-     else
-       @e
-     fi})
-
-@; indentation works even when coming from a function
-
-function foo() {
-  @list{if (1 < 2)
-          something1
-        else
-          @@@if{2<3}{something2}{something3}
-          repeat 3 {
-            @@@if{2<3}{something2}{something3}
-            @@@if{2<3}{
-              @list{something2.1
-                    something2.2}
-            }{
-              something3
-            }
-          }
-        fi}
-  return
-}

collects/tests/scribble/text/i06.ss

@@ -1,25 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@; indentation works with a list, even a single string with a newline
-@; in a list, but not in a string by itself
-
-function foo() {
-  prefix
-  @list{if (1 < 2)
-          something1
-        else
-          @list{something2
-                something3}
-          @'("something4\nsomething5")
-          @"something6\nsomething7"
-        fi}
-  return
-}
-
-@; can be used with a `display', but makes sense only at the top level
-@; or in thunks (not demonstrated here)
-@;
-@(display 123) foo @list{bar1
-                         bar2
-                         bar2}

collects/tests/scribble/text/i07.ss

@@ -1,18 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@; demonstrates using a prefix
-
-function foo() {
-  var lst = [@list{item1,
-                   item2}]
-  @prefix["//"]{ comment1
-                 comment2
-                   comment3
-                 @list{comment4
-                         comment5
-                       comment6}
-                 @prefix["*"]{ more
-                               stuff}}
-  return
-}

collects/tests/scribble/text/i08.ss

@@ -1,17 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@; using verbatim
-@(define (((foo . var) . expr1) . expr2)
-   @list{int var;
-         @verbatim{#ifdef FOO}
-         var = [@expr1,
-                @expr2];
-         @verbatim{#else}
-         var = [@expr2,
-                @expr1];
-         @verbatim{#endif}})
-
-int blah() {
-  @@@foo{i}{something}{something_else}
-}

collects/tests/scribble/text/i09.ss

@@ -1,25 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@(begin
-   ;; This is a somewhat contrived example, showing how to use lists
-   ;; and verbatim to control the added prefix
-   (define (item . text)
-     ;; notes: the `flush' makes the prefix to that point print so the
-     ;; verbatim "* " is printed after it, which overwrites the "| "
-     ;; prefix
-     (cons flush (prefix "| " (cons (verbatim "* ") text))))
-   ;; note that a simple item with spaces is much easier:
-   (define (simple . text) @list{* @text}))
-
-start
-  @item{blah blah blah
-        blah blah blah
-        @item{more stuff
-              more stuff
-              more stuff}
-        blah blah blah
-        blah blah blah}
-  @simple{more blah
-          blah blah}
-end

collects/tests/scribble/text/i10.ss

@@ -1,33 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@(define (((if . c) . t) . e)
-   @list{if (@c)
-           @t
-         else
-           @e
-         fi})
-
-function foo() {
-  @prefix["//"]{ comment1
-                 comment2 @list{comment3
-                                comment4}}
-  var x = [@list{item1,
-                 item2}]
-  bar1
-  @list{if (1 < 2)
-          @list{something1
-                something2
-                something3}
-        else
-          @@@if{2 < 3}{something_else}{something_completely_different}
-          @@@if{3 < 4}{
-            another_something_else1
-            another_something_else2
-          }{
-            another_something_completely_different
-          }
-        fi
-        }
-  return;
-}

collects/tests/scribble/text/i11.ss

@@ -1,13 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-@(define (block x)
-   @splice{{
-     blah(@x);
-   }})
-
-start
-  @splice{foo();
-          loop:}
-  @list{if (something) @block{stuff}}
-end

collects/tests/scribble/text/i12.ss

@@ -1,10 +0,0 @@
-#!/bin/env mzscheme
-#lang scribble/text
-
-  @list{
-    a
-
-    b
-  }
-
-  c

collects/tests/scribble/text/o01.txt

@@ -1 +0,0 @@
-foo

collects/tests/scribble/text/o02.txt

@@ -1,8 +0,0 @@
-Suggested price list for "PLT Scheme"
-
-0. PLT Scheme Home edition: $99.99
-1. PLT Scheme Professional edition: $149.99
-2. PLT Scheme Enterprize edition: $349.99
-
-Total: 3 items
-Average price: $199.99

collects/tests/scribble/text/o03.txt

@@ -1,14 +0,0 @@
----***---
-blah <blah <BLAH> blah> blah
-
-blah, blah, blah, blah
-
-Warning: blah overdose might be fatal
-
-My name is zee Eli
-  ... and to that I say "Foo!", I think.
-
-My name is zee Eli
-  ... and to that I say "Foo!", I think.
-
-Repeating yourself much?

collects/tests/scribble/text/o04.txt

@@ -1,19 +0,0 @@
-begin
-  a
-  b
-  c
-  d
-  e
-    f
-  g
-  h
-    i
-    j
-      k
-    l
-    m
-  n
-  o
-  p
-  q
-end

collects/tests/scribble/text/o05.txt

@@ -1,25 +0,0 @@
-function foo() {
-  if (1 < 2)
-    something1
-  else
-    if (2<3)
-      something2
-    else
-      something3
-    fi
-    repeat 3 {
-      if (2<3)
-        something2
-      else
-        something3
-      fi
-      if (2<3)
-        something2.1
-        something2.2
-      else
-        something3
-      fi
-    }
-  fi
-  return
-}

collects/tests/scribble/text/o06.txt

@@ -1,18 +0,0 @@
-function foo() {
-  prefix
-  if (1 < 2)
-    something1
-  else
-    something2
-    something3
-    something4
-    something5
-    something6
-  something7
-  fi
-  return
-}
-
-123 foo bar1
-        bar2
-        bar2

collects/tests/scribble/text/o07.txt

@@ -1,13 +0,0 @@
-function foo() {
-  var lst = [item1,
-             item2]
-  // comment1
-  // comment2
-  //   comment3
-  // comment4
-  //   comment5
-  // comment6
-  // * more
-  // * stuff
-  return
-}

collects/tests/scribble/text/o08.txt

@@ -1,10 +0,0 @@
-int blah() {
-  int var;
-#ifdef FOO
-  var = [something,
-         something_else];
-#else
-  var = [something_else,
-         something];
-#endif
-}

collects/tests/scribble/text/o09.txt

@@ -1,11 +0,0 @@
-start
-  * blah blah blah
-  | blah blah blah
-  | * more stuff
-  | | more stuff
-  | | more stuff
-  | blah blah blah
-  | blah blah blah
-  * more blah
-    blah blah
-end

collects/tests/scribble/text/o10.txt

@@ -1,26 +0,0 @@
-function foo() {
-  // comment1
-  // comment2 comment3
-  //          comment4
-  var x = [item1,
-           item2]
-  bar1
-  if (1 < 2)
-    something1
-    something2
-    something3
-  else
-    if (2 < 3)
-      something_else
-    else
-      something_completely_different
-    fi
-    if (3 < 4)
-      another_something_else1
-      another_something_else2
-    else
-      another_something_completely_different
-    fi
-  fi
-  return;
-}

collects/tests/scribble/text/o11.txt

@@ -1,7 +0,0 @@
-start
-  foo();
-loop:
-  if (something) {
-    blah(stuff);
-  }
-end

collects/tests/scribble/text/o12.txt

@@ -1,5 +0,0 @@
-  a
-
-  b
-
-  c