added a scribble/text language for preprocessing

svn: r8818

original commit: 2aa9e5fade3cf94eb0c3aac340a246228dd14418

collects/scribble/text.ss

@@ -0,0 +1,34 @@
+#lang scheme/base
+
+(require scheme/promise)
+(provide (all-from-out scheme/base scheme/promise))
+
+(define (show x p)
+  (let show ([x x])
+    (cond [(or (void? x) (not x) (null? x)) (void)]
+          [(pair? x) (show (car x)) (show (cdr x))]
+          [(promise? x) (show (force x))]
+          [(keyword? x) (show (keyword->string x))]
+          [(and (procedure? x) (procedure-arity-includes? x 0)) (show (x))]
+          ;; display won't work, since it calls us back
+          ;; [else (display x p)]
+          ;; things that are printed directly
+          [(bytes? x)  (write-bytes x p)]
+          [(string? x) (write-string x p)]
+          [(char? x)   (write-char x p)]
+          [(number? x) (write x p)]
+          ;; generic fallback
+          [else (show (format "~a" x))])))
+
+;; this is too much -- it also changes error messages
+;; (global-port-print-handler show)
+(port-display-handler (current-output-port) show)
+
+;; the default prints a newline too, avoid that
+(current-print display)
+
+;; make it possible to use this language through a repl
+;; --> won't work: need an `inside' reader that reads a single expression
+;; (require (prefix-in * "text/lang/reader.ss"))
+;; (current-prompt-read
+;;  (lambda () (parameterize ([read-accept-reader #t]) (*read-syntax))))

collects/scribble/text/lang/reader.ss

@@ -0,0 +1,32 @@
+#lang scheme/base
+
+(require (prefix-in s: "../../reader.ss"))
+
+(provide (rename-out [*read read])
+         (rename-out [*read-syntax read-syntax]))
+
+(define (*read [inp (current-input-port)])
+  (wrap inp (s:read-inside inp)))
+
+(define (*read-syntax [src #f] [port (current-input-port)])
+  (wrap port (s:read-inside-syntax src port)))
+
+(define (wrap port body)
+  (define (strip-leading-newlines stxs)
+    (if (null? stxs)
+      stxs
+      (let ([p (syntax-property (car stxs) 'scribble)])
+        (if (and (pair? p) (eq? (car p) 'newline))
+          (strip-leading-newlines (cdr stxs))
+          stxs))))
+  (let* ([p-name (object-name port)]
+         [name (if (path? p-name)
+                 (let-values ([(base name dir?) (split-path p-name)])
+                   (string->symbol (path->string (path-replace-suffix
+                                                  name #""))))
+                 'page)]
+         [id 'doc]
+         [body (if (syntax? body)
+                 (strip-leading-newlines (syntax->list body))
+                 body)])
+    `(module ,name scribble/text (#%module-begin . ,body))))