diff --git a/collects/scribble/text/lang/reader.ss b/collects/scribble/text/lang/reader.ss index a0ca9718..245b6282 100644 --- 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 new file mode 100644 index 00000000..10d4317d --- /dev/null +++ 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) ...))]))