diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index ac8cb57a6b..37630bd92e 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -48,30 +48,36 @@ body ... (#%provide (rename *read read) (rename *read-syntax read-syntax)) (define-values (*read *read-syntax) - (let* ([rd -read] - [rds -read-syntax] - [w1 -wrapper1] - [w1-extra? (and w1 (procedure-arity-includes? w1 2))] - [w1r (if w1-extra? (lambda (t) (w1 t #f)) w1)] - [w1s (if w1-extra? (lambda (t) (w1 t #t)) w1)] - [w2 (or -wrapper2 (lambda (in r) (r in)))]) + (let ([rd -read] + [rds -read-syntax] + [w1 -wrapper1] + [w2 (let ([w -wrapper2]) + (cond [(not w) (lambda (in r _) (r in))] + [(procedure-arity-includes? w 3) w] + [else (lambda (in r _) (w in r))]))]) (values (lambda (in modpath line col pos) - (w2 in (lambda (in) - (wrap-internal 'lib in rd w1r modpath #f - line col pos)))) + (w2 in + (lambda (in) + (wrap-internal 'lib in rd w1 #f modpath #f + line col pos)) + #f)) (lambda (src in modpath line col pos) - (w2 in (lambda (in) - (wrap-internal 'lib in (lambda (in) (rds src in)) - w1s modpath src - line col pos)))))))))))])) + (w2 in + (lambda (in) + (wrap-internal 'lib in (lambda (in) (rds src in)) + w1 #t modpath src + line col pos)) + #t)))))))))])) -(define (wrap-internal lib port read wrapper modpath src line col pos) +(define (wrap-internal lib port read wrapper stx? modpath src line col pos) (let* ([body (lambda () (let loop ([a null]) (let ([v (read port)]) (if (eof-object? v) (reverse a) (loop (cons v a))))))] - [body (if wrapper (wrapper body) (body))] + [body (cond [(not wrapper) (body)] + [(procedure-arity-includes? wrapper 2) (wrapper body stx?)] + [else (wrapper body)])] [p-name (object-name port)] [name (if (path? p-name) (let-values ([(base name dir?) (split-path p-name)]) @@ -79,20 +85,17 @@ (path->string (path-replace-suffix name #"")))) 'page)] [tag-src (lambda (v) - (if (syntax? modpath) - (datum->syntax #f v - (vector src line col pos - (- (or (syntax-position modpath) - (add1 pos)) - pos))) + (if stx? + (datum->syntax + #f v (vector src line col pos + (- (or (syntax-position modpath) (add1 pos)) + pos))) v))] - [lib-src (lambda (v) - (if (syntax? modpath) - (datum->syntax #f lib modpath modpath) - v))]) - `(,(tag-src 'module) ,(tag-src name) ,(lib-src lib) . ,body))) + [lib (if stx? (datum->syntax #f lib modpath modpath) lib)] + [r `(,(tag-src 'module) ,(tag-src name) ,lib . ,body)]) + (if stx? (datum->syntax #f r) r))) (define (wrap lib port read modpath src line col pos) - (wrap-internal lib port read #f modpath src line col pos)) + (wrap-internal lib port read #f #f modpath src line col pos)) ) diff --git a/collects/syntax/scribblings/common.ss b/collects/syntax/scribblings/common.ss index 9aad38f9ac..aedfb72887 100644 --- a/collects/syntax/scribblings/common.ss +++ b/collects/syntax/scribblings/common.ss @@ -5,8 +5,9 @@ scheme/contract)) (provide (all-from-out scribble/manual) - (for-label (all-from-out scheme/base - scheme/contract)) + (for-label (except-out (all-from-out scheme/base + scheme/contract) + #%module-begin)) refman) (define refman '(lib "scribblings/reference/reference.scrbl")) diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl index 0ba104fb15..e1996514e9 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -1,24 +1,31 @@ #lang scribble/doc @(require "common.ss") -@(define-syntax-rule (go) - (begin - (require (for-label syntax/module-reader)) -@begin{ +@(require (for-label syntax/module-reader)) + @title[#:tag "module-reader"]{Module Reader} @defmodule[syntax/module-reader] -The @schememodname[syntax/module-reader] language provides support -for defining @hash-lang[] readers. +The @schememodname[syntax/module-reader] language provides support for +defining @hash-lang[] readers. In its simplest form, the only thing +that is needed in the body of a @schememodname[syntax/module-reader] +is the name of the module that will be used in the language position +of read modules; using keywords, the resulting readers can be +customized in a number of ways. -@defform[(#%module-begin module-path)]{ +@defform*/subs[[(#%module-begin module-path) + (#%module-begin module-path reader-option ... body ....)] + ([reader-option (code:line #:read read-expr) + (code:line #:read-syntax read-syntax-expr) + (code:line #:wrapper1 wrapper1-expr) + (code:line #:wrapper2 wrapper2-expr)])]{ Causes a module written in the @schememodname[syntax/module-reader] language to define and provide @schemeidfont{read} and @schemeidfont{read-syntax} functions, making the module an implementation of a reader. In particular, the exported reader -functions read all S-expressions until an end-of-file, and it packages +functions read all S-expressions until an end-of-file, and package them into a new module in the @scheme[module-path] language. That is, a module @scheme[_something]@scheme[/lang/reader] implemented @@ -29,7 +36,7 @@ as module-path) ] -creates a reader that converts @scheme[#, @hash-lang[] _something] +creates a reader that converts @scheme[#,(hash-lang)_something] into @schemeblock[ @@ -45,7 +52,120 @@ For example, @scheme[scheme/base/lang/reader] is implemented as @schemeblock[ (module reader module-syntax/module-reader scheme/base) -]} +] + +The reader functions can be customized in a number of ways, using +keyword markers in the syntax of the reader module. A @scheme[#:read] +and @scheme[#:read-syntax] keywords can be used to specify functions +other than @scheme[read] and @scheme[read-syntax] to perform the +reading. For example, you can implement a +@secref[#:doc '(lib "scribblings/honu/honu.scrbl")]{Honu} reader +using: + +@schemeblock[ +(module reader module-syntax/module-reader + honu + #:read read-honu + #:read-syntax read-honu-syntax) +] + +You can also use the (optional) module body to provide more +definitions that might be needed to implement your reader functions. +For example, here is a case-insensitive reader for the +@scheme[scheme/base] language: + +@schemeblock[ +(module insensitive syntax/module-reader + scheme/base + #:read (wrap read) #:read-syntax (wrap read-syntax) + (define ((wrap reader) . args) + (parameterize ([read-case-sensitive #f]) (apply reader args)))) +] + +In many cases, however, the standard @scheme[read] and +@scheme[read-syntax] are fine, as long as you can customize the +dynamic context they're invoked at. For this, @scheme[#:wrapper1] can +specify a function that can control the dynamic context in which the +reader functions are called. It should evaluate to a function that +consumes a thunk and invokes it in the right context. Here is an +alternative definition of the case-insensitive language using +@scheme[#:wrapper1]: + +@schemeblock[ +(module insensitive syntax/module-reader + scheme/base + #:wrapper1 (lambda (t) + (parameterize ([read-case-sensitive #f]) + (t)))) +] + +Note that using a @tech[#:doc refman]{readtable}, you can implement +languages that go beyond plain S-expressions. + +In addition to this wrapper, there is also @scheme[#:wrapper2] that +has more control over the resulting reader functions. If specified, +this wrapper is handed the input port and a (one-argumet) reader +function that expects the input port as an argument. This allows this +wrapper to hand a different port value to the reader function, for +example, it can divert the read to use different file (if given a port +that corresponds to a file). Here is the case-insensitive implemented +using this option: + +@schemeblock[ +(module insensitive syntax/module-reader + scheme/base + #:wrapper2 (lambda (in r) + (parameterize ([read-case-sensitive #f]) + (r in)))) +] + +Finally, note that the two wrappers can return a different value than +the wrapped function. This introduces two more customization points +for the resulting readers: +@itemize{ + @item{The thunk that is passed to a @scheme[#:wrapper1] function + reads the file contents and returns a list of read expressions + (either syntax values or S-expressions). For example, the + following reader defines a ``language'' that ignores the contents + of the file, and simply reads files as if they were empty: + @schemeblock[ + (module ignored syntax/module-reader + scheme/base + #:wrapper1 (lambda (t) (t) '())) + ] + Note that it is still performing the read, otherwise the module + loader will complain about extra expressions.} + @item{The reader function that is passed to a @scheme[#:wrapper2] + function returns the final reault of the reader (a module + expression). You can return a different value, for example, + making it use a different language module.}} +In some rare cases, it is more convenient to know whether a reader is +invoked for a @scheme[read] or for a @scheme[read-syntax]. To +accommodate these cases, both wrappers can accept an additional +argument, and in this case, they will be handed a boolean value that +indicates whether the reader is expected to read syntax (@scheme[#t]) +or not (@scheme[#f]). For example, here is a reader that uses the +scribble syntax, and the first datum in the file determines the actual +language (which means that the library specification is effectively +ignored): +@schemeblock[ +(module scribbled syntax/module-reader + -ignored- + #:wrapper2 + (lambda (in rd stx?) + (let* ([lang (read in)] + [mod (parameterize ([current-readtable (make-at-readtable)]) + (rd in))] + [mod (if stx? mod (datum->syntax #f mod))] + [r (syntax-case mod () + [(module name lang* . body) + (with-syntax ([lang (datum->syntax + #'lang* lang #'lang*)]) + (syntax/loc mod (module name lang . body)))])]) + (if stx? r (syntax->datum r)))) + (require scribble/reader)) +] +} @defproc[(wrap-read-all [mod-path module-path?] [in input-port?] @@ -66,6 +186,3 @@ position of the module. The result is roughly @schemeblock[ `(module ,_name-id ,mod-path ,@_lst) ]} - -})) -@(go) diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss index 41570b921d..4a7a190bdb 100644 --- a/collects/tests/mzscheme/module-reader.ss +++ b/collects/tests/mzscheme/module-reader.ss @@ -43,6 +43,22 @@ #:wrapper2 (lambda (in rd) (if (syntax? (rd in)) #'(module page zzz) '(module page zzz)))) +;; a module that uses the scribble syntax with a specified language +(module r9 syntax/module-reader -ignored- + #:wrapper2 + (lambda (in rd stx?) + (let* ([lang (read in)] + [mod (parameterize ([current-readtable (make-at-readtable)]) + (rd in))] + [mod (if stx? mod (datum->syntax #f mod))] + [r (syntax-case mod () + [(module name lang* . body) + (with-syntax ([lang (datum->syntax + #'lang* lang #'lang*)]) + (syntax/loc mod (module name lang . body)))])]) + (if stx? r (syntax->datum r)))) + (require scribble/reader)) + (define (from-string read str) (parameterize ([read-accept-reader #t]) (read (open-input-string str)))) @@ -68,6 +84,11 @@ (test-both "#reader 'r6 (define foo #:bar)" '(module page zzz)) +(test-both "#reader 'r9 scheme/base (define foo 1)" + '(module page scheme/base (define foo 1))) +(test-both "#reader 'r9 scheme/base @define[foo]{one}" + '(module page scheme/base (define foo "one"))) + ;; ---------------------------------------- (report-errs)