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

Fixed scribble bug #15. Also cleaned up code by currying the racketblock vs RACKETBLOCK parameter for chunk and CHUNK instead of calling define-syntax-rule twice.

Browse Source
This commit is contained in:
Georges Dupéron 2016-06-17 15:14:45 +02:00
parent c34a69c623
commit a3f8e6a6d6
1 changed files with 57 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
scribble-lib/scribble/private/lp.rkt
View File

@ -14,62 +14,68 @@
(define (init-chunk-number id)
(free-identifier-mapping-put! chunk-numbers id 2)))
(define-syntax-rule (define-chunk chunk-id racketblock)
(define-syntax (chunk-id 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 (syntax-local-introduce #'name))]
[str (symbol->string (syntax-e #'name))]
[tag (format "~a:~a" str (or n 1))])
(when n
(inc-chunk-number (syntax-local-introduce #'name)))
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...))))
(with-syntax ([tag tag]
[str str]
[((for-label-mod (... ...)) (... ...))
(map (lambda (expr)
(syntax-case expr (require)
[(require mod (... ...))
(let loop ([mods (syntax->list #'(mod (... ...)))])
(cond
[(null? mods) null]
[else
(syntax-case (car mods) (for-syntax)
[(for-syntax x (... ...))
(append (loop (syntax->list #'(x (... ...))))
(loop (cdr mods)))]
[x
(cons #'x (loop (cdr mods)))])]))]
[else null]))
(syntax->list #'(expr (... ...))))]
[(rest (... ...)) (if n
#`((subscript #,(format "~a" n)))
#`())])
#`(begin
(require (for-label for-label-mod (... ...) (... ...)))
#,@(if n
(define-for-syntax ((make-chunk racketblock) 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 (syntax-local-introduce #'name))]
[str (symbol->string (syntax-e #'name))]
[tag (format "~a:~a" str (or n 1))])
(when n
(inc-chunk-number (syntax-local-introduce #'name)))
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
(with-syntax ([tag tag]
[str str]
[((for-label-mod ...) ...)
(map (lambda (expr)
(syntax-case expr (require)
[(require mod ...)
(let loop ([mods (syntax->list #'(mod ...))])
(cond
[(null? mods) null]
[else
(syntax-case (car mods)
(for-syntax quote submod)
[(submod ".." . _)
(loop (cdr mods))]
[(submod "." . _)
(loop (cdr mods))]
[(quote x)
(loop (cdr mods))]
[(for-syntax x ...)
(append (loop (syntax->list #'(x ...)))
(loop (cdr mods)))]
[x
(cons #'x (loop (cdr mods)))])]))]
[else null]))
(syntax->list #'(expr ...)))]
[(rest ...) (if n
#`((subscript #,(format "~a" n)))
#`())])
#`(begin
(require (for-label for-label-mod ... ...))
#,@(if n
#'()
#'((define-syntax name (make-element-id-transformer
(lambda (stx) #'(chunkref name))))
(begin-for-syntax (init-chunk-number #'name))))
(make-splice
(list (make-toc-element
#f
(list (elemtag '(chunk tag)
(bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk tag) #:underline? #f
str
rest (... ...)))))
(racketblock expr (... ...)))))))])))
(make-splice
(list (make-toc-element
#f
(list (elemtag '(chunk tag)
(bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk tag) #:underline? #f
str
rest ...))))
(#,racketblock expr ...))))))]))
(define-chunk chunk racketblock)
(define-chunk CHUNK RACKETBLOCK)
(define-syntax chunk (make-chunk #'racketblock))
(define-syntax CHUNK (make-chunk #'RACKETBLOCK))
(define-syntax (chunkref stx)
(syntax-case stx ()