changed the way the literate program setup works

svn: r13774

original commit: 121764e7b57f7906f4d7420bdfa938621e371e18

collects/scribble/lp-include.ss

@@ -1,61 +1,20 @@
 #lang scheme/base
 
-;; Use this module to create literate doc wrappers -- files that require the
+(require scheme/include (for-syntax scheme/base)
-;; literate code in a way that makes it a scribble file.
+          (only-in scribble/private/lp chunk)
+          scribble/manual)
 
-(provide chunk (all-from-out scribble/manual))
+(provide lp-include)
 
-(require scribble/manual scribble/decode scribble/struct
+(define-syntax (module stx)
-         scribble/scheme
-         (for-syntax scheme/base syntax/boundmap))
-
-(begin-for-syntax
-  ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
-  ;; of the same name
-  (define chunk-numbers (make-free-identifier-mapping))
-  (define (get-chunk-number id)
-    (let ([n (add1 (free-identifier-mapping-get chunk-numbers id
-                                                (lambda () 0)))])
-      (free-identifier-mapping-put! chunk-numbers id n)
-      n)))
-
-;; This is the doc-view implementation of `chunk', see "literate-lang.ss" for
-;; the cide-view implementation.  Defines `chunk' as a macro that typesets the
-;; contained code.
-(define-syntax (chunk stx)
   (syntax-case stx ()
-    [(_ name expr ...)
+    [(module name base body ...)
-     ;; no need for more error checking, using chunk for the code will do that
+     (begin
-     (identifier? #'name)
+       #'(begin body ...))]))
-     (let ([n (get-chunk-number #'name)]
-           [str (symbol->string (syntax-e #'name))])
-       (if (n . > . 1)
-           #'(void)
-           (with-syntax ([tag str]
-                         [str str]
-                         [((for-label-mod ...) ...)
-                          (map (lambda (expr)
-                                 (syntax-case expr (require)
-                                   [(require mod ...)
-                                    #'(mod ...)]
-                                   [else null]))
-                               (syntax->list #'(expr ...)))])
-             #`(begin
-                 (define-syntax name (make-element-id-transformer
-                                      (lambda (stx) #'(chunkref name))))
-                 (require (for-label for-label-mod ... ...))
-                 (make-splice
-                  (list (make-toc-element
-                         #f
-                         (list (elemtag '(chunk tag)
-                                        (bold (italic (scheme name)) " ::=")))
-                         (list (smaller (elemref '(chunk tag) #:underline? #f
-                                                 str))))
-                        (schemeblock expr ...)))))))]))
 
-(define-syntax (chunkref stx)
+(define-syntax (lp-include stx)
   (syntax-case stx ()
-    [(_ id)
+    [(_ name)
-     (identifier? #'id)
+     (with-syntax ([there (datum->syntax stx 'there)])
-     (with-syntax ([str (format "~a" (syntax-e #'id))])
+       #'(include-at/relative-to here there name))]))
-       #'(elemref '(chunk str) #:underline? #f str))]))
+

collects/scribble/lp/lang/lang.ss

@@ -1,8 +1,7 @@
 #lang scheme/base
 
 (provide (except-out (all-from-out scheme/base) #%module-begin)
-         (rename-out [module-begin #%module-begin])
+         (rename-out [module-begin #%module-begin]))
-         chunk)
 
 (require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase))
 
@@ -25,22 +24,6 @@
      chunks id
      `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs)))))
 
-;; This is the code-view implementation of `chunk', see
-;; "literate-doc-wrapper.ss" for the doc-view implementation.  Defines
-;; `chunk' as a macro that collects the code to be later reassembled
-;; by `tangle'.
-(define-syntax (chunk stx)
-  (syntax-case stx ()
-    [(_ name expr ...)
-     (cond [(not (identifier? #'name))
-            (raise-syntax-error #f "expected a chunk name" stx #'name)]
-           [(not (regexp-match? #rx"^<.*>$" (symbol->string (syntax-e #'name))))
-            (raise-syntax-error
-             #f "chunk names must begin and end with angle brackets, <...>"
-             stx #'name)]
-           [else (add-to-chunk! #'name (syntax->list #'(expr ...)))
-                 #'(void)])]))
-
 (define-syntax (tangle stx)
   (define chunk-mentions '())
   (define body
@@ -68,41 +51,27 @@
                              chunk-mentions)])
     #`(begin body ... (let ([b-id (void)]) b-use) ...)))
 
-(define-syntax (literate-begin stx)
+(define-for-syntax (extract-chunks exprs)
-  (syntax-case stx ()
+  (let loop ([exprs exprs])
-    [(_ . exprs)
+    (syntax-case exprs ()
-     (let loop ([exprs #'exprs])
+      [() (void)]
-       (syntax-case exprs ()
+      [(expr . exprs)
-         [() #'(tangle)]
+       (syntax-case #'expr (define-syntax quote-syntax)
-         [(expr . exprs)
+         [(define-values (lifted) (quote-syntax (a-chunk id body ...)))
-          (let ([expanded
+          (eq? (syntax-e #'a-chunk) 'a-chunk)
-                 (local-expand #'expr
+          (begin
-                               'module
+            (add-to-chunk! #'id (syntax->list #'(body ...)))
-                               (append (kernel-form-identifier-list)
+            (loop #'exprs))]
-                                       (syntax->list #'(provide
+         [_ 
-                                                        require
+          (loop #'exprs)])])))
-                                                        chunk
-                                                        #%provide
-                                                        #%require))))])
-            (syntax-case expanded (begin chunk require/chunk)
-              [(begin rest ...)
-               (loop (datum->syntax
-                      expanded
-                      (append
-                       (syntax->list #'(rest ...))
-                       #'exprs)))]
-              [(id . _)
-               (ormap (lambda (kw) (free-identifier=? #'id kw))
-                      (syntax->list #'(require
-                                       provide
-                                       chunk
-                                       #%require
-                                       #%provide)))
-               #`(begin #,expanded (literate-begin . exprs))]
-              [else (loop #'exprs)]))]))]))
 
 (define-syntax (module-begin stx)
   (syntax-case stx ()
     [(_ id exprs . body)
-     #'(#%module-begin
+     (let ([expanded 
-        (literate-begin id exprs . body))]))
+            (expand `(,#'module scribble-lp-tmp-name scribble/private/lp
+                                ,@(syntax->datum #'(id exprs . body))))])
+       (syntax-case expanded ()
+         [(module name lang (mb . stuff))
+          (begin (extract-chunks #'stuff)
+                 #'(#%module-begin (tangle)))]))]))

collects/scribble/private/lp.ss

@@ -0,0 +1,68 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)
+         scribble/scheme scribble/decode scribble/manual scribble/struct)
+
+(begin-for-syntax
+  ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
+  ;; of the same name
+  (define chunk-numbers (make-free-identifier-mapping))
+  (define (get-chunk-number id)
+    (let ([n (add1 (free-identifier-mapping-get chunk-numbers id
+                                                (lambda () 0)))])
+      (free-identifier-mapping-put! chunk-numbers id n)
+      n)))
+
+(define-syntax (chunk stx)
+  (syntax-case stx ()
+    [(_ name expr ...) 
+     ;; no need for more error checking, using chunk for the code will do that
+     (identifier? #'name)
+     (let ([n (get-chunk-number #'name)]
+           [str (symbol->string (syntax-e #'name))])
+
+       (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
+       
+       (if (n . > . 1)
+           (let ([str
+                  (format 
+                   "need to handle secondary tags: ~a ~a\n"
+                   n 
+                   str)])
+             #`(begin
+                 (italic #,str)))
+           (with-syntax ([tag str]
+                         [str str]
+                         [((for-label-mod ...) ...)
+                          (map (lambda (expr)
+                                 (syntax-case expr (require)
+                                   [(require mod ...)
+                                    #'(mod ...)]
+                                   [else null]))
+                               (syntax->list #'(expr ...)))])
+             #`(begin
+                 (require (for-label for-label-mod ... ...))
+                 ;; why does this happen twice?
+                 #;
+                 (define-syntax name (make-element-id-transformer
+                                      (lambda (stx) #'(chunkref name))))
+                 (make-splice
+                  (list (make-toc-element
+                         #f
+                         (list (elemtag '(chunk tag)
+                                        (bold (italic (scheme name)) " ::=")))
+                         (list (smaller (elemref '(chunk tag) #:underline? #f
+                                                 str))))
+                        (schemeblock expr ...)))))))]))
+
+(define-syntax (chunkref stx)
+  (syntax-case stx ()
+    [(_ id)
+     (identifier? #'id)
+     (with-syntax ([str (format "~a" (syntax-e #'id))])
+       #'(elemref '(chunk str) #:underline? #f str))]))
+
+
+(provide (all-from-out scheme/base
+                       scribble/manual)
+         chunk)