From 7eab88977b28b857de0b9eddfae6a7967c913bd7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Feb 2009 17:22:02 +0000 Subject: [PATCH] changed the way the literate program setup works svn: r13774 original commit: 121764e7b57f7906f4d7420bdfa938621e371e18 --- collects/scribble/lp-include.ss | 67 ++++++---------------------- collects/scribble/lp/lang/lang.ss | 73 +++++++++---------------------- collects/scribble/private/lp.ss | 68 ++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 106 deletions(-) create mode 100644 collects/scribble/private/lp.ss diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss index 2c68e8c1..dfc75496 100644 --- 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 index c543eebe..6a2d9511 100644 --- 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 new file mode 100644 index 00000000..229afa89 --- /dev/null +++ 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)