First version of textlang, using state to eliminate newlines

svn: r11552

collects/scribble/text/lang/reader.ss

@@ -1,32 +1,9 @@
-#lang scheme/base
+#lang s-exp syntax/module-reader
 
-(require "../../text.ss")
+scribble/text/textlang
 
-(provide (rename-out [*read read])
+#:read        scribble:read-inside
-         (rename-out [*read-syntax read-syntax]))
+#:read-syntax scribble:read-syntax-inside
+#:whole-body-readers? #t
 
-(define (*read [inp (current-input-port)])
+(require (prefix-in scribble: "../../reader.ss"))
-  (wrap inp (at:read-inside inp)))
-
-(define (*read-syntax [src #f] [port (current-input-port)])
-  (wrap port (at:read-syntax-inside 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 . ,body)))

collects/scribble/text/textlang.ss

@@ -0,0 +1,45 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base syntax/kerncase)
+         scheme/promise "../text.ss")
+
+(provide (except-out (all-from-out scheme/base) #%module-begin)
+         (rename-out [module-begin #%module-begin])
+         (all-from-out scheme/promise "../text.ss"))
+
+(begin-for-syntax
+  (define definition-ids ; ids that don't require forcing
+    (syntax->list #'(define-values define-syntaxes define-values-for-syntax
+                     require provide #%require #%provide)))
+  (define stoplist (append definition-ids (kernel-form-identifier-list)))
+  (define (definition-id? id)
+    (and (identifier? id)
+         (ormap (lambda (i) (free-identifier=? id i)) definition-ids)))
+  (define (newline-stx? stx)
+    (let ([p (syntax-property stx 'scribble)])
+      (and (pair? p) (eq? (car p) 'newline))))
+  (define swallow-newlines? #t))
+
+;; use `swallow-newlines?' for state, to get rid of newlines that follow
+;; definition expressions (must do that, since we need to expand expressions
+;; one-by-one, so #%module-begin will do its job) -- this relies on
+;; left-to-right macro expansion.
+
+(define-syntax (toplevel-decorate stx)
+  (let ([context (syntax-local-context)])
+    (syntax-case stx ()
+      [(this expr)
+       (let ([expr* (local-expand #'expr context stoplist)])
+         (syntax-case expr* (begin)
+           [(begin x ...) #'(begin (this x) ...)]
+           [(id . rest) (definition-id? #'id)
+            (begin (set! swallow-newlines? #t) expr*)]
+           [_ (if (and swallow-newlines? (newline-stx? expr*))
+                #'(begin)
+                (begin (set! swallow-newlines? #f) #`(output #,expr*)))]))])))
+
+(define-syntax (module-begin stx)
+  (syntax-case stx ()
+    [(_ expr ...)
+     (begin (set! swallow-newlines? #t) ; not really necessary
+            #'(#%module-begin (toplevel-decorate expr) ...))]))