suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

changed the way the literate program setup works

Browse Source 
svn: r13774

original commit: 121764e7b57f7906f4d7420bdfa938621e371e18
This commit is contained in:
Robby Findler 2009-02-21 17:22:02 +00:00
parent a6002db1ec
commit 7eab88977b
3 changed files with 102 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/scribble/lp-include.ss
View File

@ -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))]))

73
collects/scribble/lp/lang/lang.ss
View File

@ -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)))]))]))

68
collects/scribble/private/lp.ss Normal file
View File

@ -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)