Fixed scribble bug #15. Also cleaned up code by currying the racketbl…

…ock vs RACKETBLOCK parameter for chunk and CHUNK instead of calling define-syntax-rule twice.
racket · Jun 17, 2016 · e1ff6f1 · e1ff6f1
1 parent c34a69c
commit e1ff6f1
Showing 1 changed file with 57 additions and 51 deletions.
diff --git 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 ()