The scribble/text language works much better now, with

indentation-aware output being possible.

svn: r14025

collects/scribble/text/output.ss

@@ -2,19 +2,107 @@
 
 (require scheme/promise)
 
-(provide output)
+(provide output verbatim unverbatim prefix)
+
 (define (output x [p (current-output-port)])
-  (let loop ([x x])
-    (cond [(or (void? x) (not x) (null? x)) (void)]
-          [(pair? x) (loop (car x)) (loop (cdr x))]
-          [(promise? x) (loop (force x))]
-          [(keyword? x) (loop (keyword->string x))]
-          [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
-          [(bytes? x)  (write-bytes x p)]
-          [(string? x) (write-string x p)]
-          [(char? x)   (write-char x p)]
-          [(number? x) (write x p)]
-          [(symbol? x) (display x p)]
-          ;; generic fallback
-          [else (error 'output "don't know how to render value: ~v" x)]))
+  (define (getcol) (let-values ([(line col pos) (port-next-location p)]) col))
+  (port-count-lines! p)
+  ;; pfx can be a column number, or a byte-string, or #f for nothing at all
+  (let loop ([x x] [pfx (getcol)])
+    ;; new can be a new target column number or an additional prefix to add (a
+    ;; string or a byte string)
+    (define (combine-pfx pfx new)
+      (and pfx new
+           (if (number? pfx)
+             (if (number? new)
+               ;; new target column
+               (max pfx new)
+               ;; add a prefix to existing column
+               (bytes-append (make-spaces pfx)
+                             (if (string? new) (string->bytes/utf-8 new) new)))
+             (if (number? new)
+               ;; add spaces to get to the target column after
+               (let ([cur (bytes-length pfx)])
+                 (if (new . > . cur)
+                   (bytes-append pfx (make-spaces (- new cur)))
+                   pfx))
+               ;; append prefixes
+               (bytes-append pfx (if (string? new)
+                                   (string->bytes/utf-8 new)
+                                   new))))))
+    ;; used to output strings and byte strings, where each internal newline
+    ;; should be followed by the prefix
+    (define (do-string write get-length nl-rx)
+      (define len (get-length x))
+      (define ms (and pfx (or (bytes? pfx) (pfx . > . 0)) (len . > . 0)
+                      (regexp-match-positions* nl-rx x)))
+      (if (pair? ms)
+        (let ([pfx (if (bytes? pfx) pfx (make-spaces pfx))])
+          (let loop ([start 0] [ms ms])
+            (let ([i (cdar ms)])
+              (write x p start i)
+              (when (< i len)
+                (write-bytes pfx p)
+                (if (null? (cdr ms))
+                  (write x p i)
+                  (loop i (cdr ms)))))))
+        (write x p)))
+    (cond
+      ;; no output for these
+      [(or (void? x) (not x) (null? x)) (void)]
+      ;; for lists and pairs the indentation at the beginning is used, then
+      ;; output the contents recursively
+      [(pair? x) (let ([pfx (combine-pfx pfx (getcol))])
+                   (if (list? x)
+                     (for ([x (in-list x)]) (loop x pfx))
+                     (begin (loop (car x) pfx) (loop (cdr x) pfx))))]
+      ;; delayed values
+      [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x) pfx)]
+      [(promise? x) (loop (force x) pfx)]
+      ;; special output wrappers
+      [(special? x)
+       (let ([c (special-contents x)])
+         (case (special-flag x)
+           [(verbatim)   (loop c #f)]
+           [(unverbatim) (loop c (getcol))]
+           [(prefix)
+            (let ([pfx (combine-pfx (combine-pfx pfx (getcol)) (car c))])
+              ;; could also do: (loop (cdr c) pfx), but save time
+              (for ([x (in-list (cdr c))]) (loop x pfx)))]
+           [else (error 'output "unknown special value flag: ~e"
+                        (special-flag x))]))]
+      ;; the rest will cause some output, so show the prefix and go
+      [else (when pfx
+              (let ([cur (getcol)])
+                (if (number? pfx)
+                  ;; number: add spaces to get to that column
+                  (let ([n (- pfx cur)])
+                    (when (> n 0) (write-bytes (make-spaces n) p)))
+                  ;; prefix: omit characters from the prefix that we went past
+                  (cond [(zero? cur) (write-bytes pfx p)]
+                        [(< cur (bytes-length pfx)) (write-bytes pfx p cur)]))))
+            (cond
+              ;; strings output indentation in internal newlines too
+              [(string? x) (do-string write-string string-length #rx"\n")]
+              [(bytes?  x) (do-string write-bytes  bytes-length  #rx#"\n")]
+              ;; additional values that are displayed as usual
+              [(symbol? x) (display x p)]
+              [(char? x)   (write-char x p)]
+              [(number? x) (write x p)]
+              ;; useful to represent attributes with keywords (same as symbols)
+              [(keyword? x) (write-string (keyword->string x) p)]
+              ;; generic fallback: throw an error
+              [else (error 'output "don't know how to render value: ~v" x)])]))
   (void))
+
+(define-struct special (flag contents))
+
+(define (verbatim   . contents) (make-special 'verbatim   contents))
+(define (unverbatim . contents) (make-special 'unverbatim contents))
+(define (prefix pfx . contents) (make-special 'prefix (cons pfx contents)))
+
+(define make-spaces
+  (let ([t (make-hasheq)])
+    (lambda (n)
+      (or (hash-ref t n #f)
+          (let ([spaces (make-bytes n 32)]) (hash-set! t n spaces) spaces)))))

collects/scribble/text/syntax-utils.ss

@@ -112,7 +112,9 @@
 
 ;; module-begin for text files
 (define-syntax-rule (module-begin/text expr ...)
-  (process-begin/text #%plain-module-begin output expr ...))
+  (#%plain-module-begin
+   (port-count-lines! (current-output-port))
+   (process-begin/text begin output expr ...)))
 
 ;; `begin'-like utility that allows definitions and collects values
 (define-for-syntax (split-collect-body exprs ctx)

collects/tests/scribble/text/i10.ss

@@ -0,0 +1,33 @@
+#!/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/i2.ss

@@ -5,7 +5,7 @@
 Suggested price list for "@name"
 
 @; test mutual recursion, throwing away inter-definition spaces
-@; <-- this is needed to get one line of space only
+@; <-- this is needed to get only one line of space above
 @(define (items-num)
    (length items))
 

collects/tests/scribble/text/i4.ss

@@ -0,0 +1,24 @@
+#!/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/i5.ss

@@ -0,0 +1,30 @@
+#!/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/i6.ss

@@ -0,0 +1,25 @@
+#!/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/i7.ss

@@ -0,0 +1,18 @@
+#!/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/i8.ss

@@ -0,0 +1,17 @@
+#!/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/i9.ss

@@ -0,0 +1,25 @@
+#!/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 "" makes the prefix to that point print so the
+     ;; prefix is added after it, and the "* " is wrapped in verbatim
+     ;; so that line doesn't get the "| " prefix
+     (cons "" (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/o10.txt

@@ -0,0 +1,26 @@
+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/o4.txt

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

collects/tests/scribble/text/o5.txt

@@ -0,0 +1,25 @@
+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/o6.txt

@@ -0,0 +1,18 @@
+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/o7.txt

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

collects/tests/scribble/text/o8.txt

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

collects/tests/scribble/text/o9.txt

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