From a3f8e6a6d6096d80bb147832e428d9fe6da48837 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 17 Jun 2016 15:14:45 +0200 Subject: [PATCH] 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. --- scribble-lib/scribble/private/lp.rkt | 108 ++++++++++++++------------- 1 file changed, 57 insertions(+), 51 deletions(-) diff --git a/scribble-lib/scribble/private/lp.rkt b/scribble-lib/scribble/private/lp.rkt index 3416ce08..c068ae86 100644 --- a/scribble-lib/scribble/private/lp.rkt +++ b/scribble-lib/scribble/private/lp.rkt @@ -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 ()