commit 60377e2c3e552fd0cbf62511f859bb72b8002176
parent 970dcd1ab0e8c5035ee9502c887b0589ff25e04e
Author: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 5 Sep 2008 12:38:53 +0000
First version of textlang, using state to eliminate newlines
svn: r11552
original commit: 672a37150d5a67a36714c8211799bd645a5cf37f
Diffstat:
2 files changed, 51 insertions(+), 29 deletions(-)
diff --git a/collects/scribble/text/lang/reader.ss b/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])
- (rename-out [*read-syntax read-syntax]))
+#:read scribble:read-inside
+#:read-syntax scribble:read-syntax-inside
+#:whole-body-readers? #t
-(define (*read [inp (current-input-port)])
- (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)))
+(require (prefix-in scribble: "../../reader.ss"))
diff --git a/collects/scribble/text/textlang.ss b/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) ...))]))
