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

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

@ -14,10 +14,9 @@
(define (init-chunk-number id) (define (init-chunk-number id)
(free-identifier-mapping-put! chunk-numbers id 2))) (free-identifier-mapping-put! chunk-numbers id 2)))
(define-syntax-rule (define-chunk chunk-id racketblock) (define-for-syntax ((make-chunk racketblock) stx)
(define-syntax (chunk-id stx)
(syntax-case stx () (syntax-case stx ()
[(_ name expr (... ...)) [(_ name expr ...)
;; no need for more error checking, using chunk for the code will do that ;; no need for more error checking, using chunk for the code will do that
(identifier? #'name) (identifier? #'name)
(let* ([n (get-chunk-number (syntax-local-introduce #'name))] (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
@ -27,32 +26,39 @@
(when n (when n
(inc-chunk-number (syntax-local-introduce #'name))) (inc-chunk-number (syntax-local-introduce #'name)))
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...)))) (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
(with-syntax ([tag tag] (with-syntax ([tag tag]
[str str] [str str]
[((for-label-mod (... ...)) (... ...)) [((for-label-mod ...) ...)
(map (lambda (expr) (map (lambda (expr)
(syntax-case expr (require) (syntax-case expr (require)
[(require mod (... ...)) [(require mod ...)
(let loop ([mods (syntax->list #'(mod (... ...)))]) (let loop ([mods (syntax->list #'(mod ...))])
(cond (cond
[(null? mods) null] [(null? mods) null]
[else [else
(syntax-case (car mods) (for-syntax) (syntax-case (car mods)
[(for-syntax x (... ...)) (for-syntax quote submod)
(append (loop (syntax->list #'(x (... ...)))) [(submod ".." . _)
(loop (cdr mods))]
[(submod "." . _)
(loop (cdr mods))]
[(quote x)
(loop (cdr mods))]
[(for-syntax x ...)
(append (loop (syntax->list #'(x ...)))
(loop (cdr mods)))] (loop (cdr mods)))]
[x [x
(cons #'x (loop (cdr mods)))])]))] (cons #'x (loop (cdr mods)))])]))]
[else null])) [else null]))
(syntax->list #'(expr (... ...))))] (syntax->list #'(expr ...)))]
[(rest (... ...)) (if n [(rest ...) (if n
#`((subscript #,(format "~a" n))) #`((subscript #,(format "~a" n)))
#`())]) #`())])
#`(begin #`(begin
(require (for-label for-label-mod (... ...) (... ...))) (require (for-label for-label-mod ... ...))
#,@(if n #,@(if n
#'() #'()
#'((define-syntax name (make-element-id-transformer #'((define-syntax name (make-element-id-transformer
@ -65,11 +71,11 @@
(bold (italic (racket name)) " ::="))) (bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk tag) #:underline? #f (list (smaller (elemref '(chunk tag) #:underline? #f
str str
rest (... ...))))) rest ...))))
(racketblock expr (... ...)))))))]))) (#,racketblock expr ...))))))]))
(define-chunk chunk racketblock) (define-syntax chunk (make-chunk #'racketblock))
(define-chunk CHUNK RACKETBLOCK) (define-syntax CHUNK (make-chunk #'RACKETBLOCK))
(define-syntax (chunkref stx) (define-syntax (chunkref stx)
(syntax-case stx () (syntax-case stx ()