* Minor extension (#:wrapper2 can accept an stx? boolean too)

* Added a more sophisticated test (scribble syntax with an arbitrary
  language), based on documentation example
* Documentation

svn: r11502

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]
+              (let ([rd  -read]
-                     [rds -read-syntax]
+                    [rds -read-syntax]
-                     [w1  -wrapper1]
+                    [w1  -wrapper1]
-                     [w1-extra? (and w1 (procedure-arity-includes? w1 2))]
+                    [w2  (let ([w -wrapper2])
-                     [w1r (if w1-extra? (lambda (t) (w1 t #f)) w1)]
+                           (cond [(not w) (lambda (in r _) (r in))]
-                     [w1s (if w1-extra? (lambda (t) (w1 t #t)) w1)]
+                                 [(procedure-arity-includes? w 3) w]
-                     [w2  (or -wrapper2 (lambda (in r) (r in)))])
+                                 [else (lambda (in r _) (w in r))]))])
                 (values
                  (lambda (in modpath line col pos)
-                   (w2 in (lambda (in)
+                   (w2 in
-                            (wrap-internal 'lib in rd w1r modpath #f
+                       (lambda (in)
-                                           line col pos))))
+                         (wrap-internal 'lib in rd w1 #f modpath #f
+                                        line col pos))
+                       #f))
                  (lambda (src in modpath line col pos)
-                   (w2 in (lambda (in)
+                   (w2 in
-                            (wrap-internal 'lib in (lambda (in) (rds src in))
+                       (lambda (in)
-                                           w1s modpath src
+                         (wrap-internal 'lib in (lambda (in) (rds src in))
-                                           line col pos)))))))))))]))
+                                        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)
+                    (if stx?
-                      (datum->syntax #f v
+                      (datum->syntax
-                                     (vector src line col pos
+                       #f v (vector src line col pos
-                                             (- (or (syntax-position modpath)
+                                    (- (or (syntax-position modpath) (add1 pos))
-                                                    (add1 pos))
+                                       pos)))
-                                                pos)))
                       v))]
-         [lib-src (lambda (v)
+         [lib (if stx? (datum->syntax #f lib modpath modpath) lib)]
-                    (if (syntax? modpath)
+         [r `(,(tag-src 'module) ,(tag-src name) ,lib . ,body)])
-                      (datum->syntax #f lib modpath modpath)
+    (if stx? (datum->syntax #f r) r)))
-                      v))])
-    `(,(tag-src 'module) ,(tag-src name) ,(lib-src lib) . ,body)))
 
 (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))
 
 )

collects/syntax/scribblings/common.ss

@@ -5,8 +5,9 @@
                     scheme/contract))
 
 (provide (all-from-out scribble/manual)
-         (for-label (all-from-out scheme/base
+         (for-label (except-out (all-from-out scheme/base
-                                  scheme/contract))
+                                              scheme/contract)
+                                #%module-begin))
          refman)
 
 (define refman '(lib "scribblings/reference/reference.scrbl"))

collects/syntax/scribblings/module-reader.scrbl

@@ -1,24 +1,31 @@
 #lang scribble/doc
 @(require "common.ss")
 
-@(define-syntax-rule (go)
+@(require (for-label syntax/module-reader))
-  (begin
+
-    (require (for-label syntax/module-reader))
-@begin{
 @title[#:tag "module-reader"]{Module Reader}
 
 @defmodule[syntax/module-reader]
 
-The @schememodname[syntax/module-reader] language provides support
+The @schememodname[syntax/module-reader] language provides support for
-for defining @hash-lang[] readers.
+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)

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)