commit 7eab88977b28b857de0b9eddfae6a7967c913bd7
parent a6002db1ecd233e751dbe09af5709e09c6653d17
Author: Robby Findler <robby@racket-lang.org>
Date: Sat, 21 Feb 2009 17:22:02 +0000
changed the way the literate program setup works
svn: r13774
original commit: 121764e7b57f7906f4d7420bdfa938621e371e18
Diffstat:
3 files changed, 102 insertions(+), 106 deletions(-)
diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss
@@ -1,61 +1,20 @@
#lang scheme/base
-;; Use this module to create literate doc wrappers -- files that require the
-;; literate code in a way that makes it a scribble file.
+(require scheme/include (for-syntax scheme/base)
+ (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
- 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)
+(define-syntax (module 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))])
- (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 ...)))))))]))
+ [(module name base body ...)
+ (begin
+ #'(begin body ...))]))
-(define-syntax (chunkref stx)
+(define-syntax (lp-include stx)
(syntax-case stx ()
- [(_ id)
- (identifier? #'id)
- (with-syntax ([str (format "~a" (syntax-e #'id))])
- #'(elemref '(chunk str) #:underline? #f str))]))
+ [(_ name)
+ (with-syntax ([there (datum->syntax stx 'there)])
+ #'(include-at/relative-to here there name))]))
+
diff --git a/collects/scribble/lp/lang/lang.ss b/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])
- chunk)
+ (rename-out [module-begin #%module-begin]))
(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)
- (syntax-case stx ()
- [(_ . exprs)
- (let loop ([exprs #'exprs])
- (syntax-case exprs ()
- [() #'(tangle)]
- [(expr . exprs)
- (let ([expanded
- (local-expand #'expr
- 'module
- (append (kernel-form-identifier-list)
- (syntax->list #'(provide
- require
- 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-for-syntax (extract-chunks exprs)
+ (let loop ([exprs exprs])
+ (syntax-case exprs ()
+ [() (void)]
+ [(expr . exprs)
+ (syntax-case #'expr (define-syntax quote-syntax)
+ [(define-values (lifted) (quote-syntax (a-chunk id body ...)))
+ (eq? (syntax-e #'a-chunk) 'a-chunk)
+ (begin
+ (add-to-chunk! #'id (syntax->list #'(body ...)))
+ (loop #'exprs))]
+ [_
+ (loop #'exprs)])])))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ id exprs . body)
- #'(#%module-begin
- (literate-begin id exprs . body))]))
+ (let ([expanded
+ (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)))]))]))
diff --git a/collects/scribble/private/lp.ss b/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)
