From 6f5e7d92ffd57966269a97ccf90893e31b72b2de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 20 Sep 2016 07:12:44 +0200 Subject: [PATCH] Added auto-parentheses for repeated chunks, and finally (hopefully) fixed the link numbering problems (last bug was that the save-as chunks had numbers total+i, but the references within the code were made to the number 1 which did not exist). --- private/common.rkt | 3 +- private/lp.rkt | 100 ++++++++++++++++++++++++++++++--------------- 2 files changed, 68 insertions(+), 35 deletions(-) diff --git a/private/common.rkt b/private/common.rkt index c41a72b7..73184d0a 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -218,8 +218,7 @@ b) (define-syntax-rule (when-preexpanding . b) (begin)) - (define-syntax-rule - (unless-preexpanding . b) + (define-syntax-rule (unless-preexpanding . b) (begin . b)) (require scribble-enhanced/with-manual scribble-enhanced diff --git a/private/lp.rkt b/private/lp.rkt index 894c1817..12e03c8c 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -19,18 +19,23 @@ (+ 1 (free-identifier-mapping-get chunk-numbers id)))) (define (init-chunk-number id) (free-identifier-mapping-put! chunk-numbers id 2)) - (define repeat-chunk-numbers (make-free-identifier-mapping)) + (define (init-repeat-chunk-number id) + (free-identifier-mapping-put! repeat-chunk-numbers id 1)) + (define (get-repeat-chunk-number id) + (free-identifier-mapping-get repeat-chunk-numbers + id + (lambda () 1))) (define (get+increment-repeat-chunk-number! id) (let ([current (free-identifier-mapping-get repeat-chunk-numbers id (lambda () 1))]) - (free-identifier-mapping-put! repeat-chunk-numbers id (add1 current)) ;; note: due to multiple expansions, this does not increase exactly one at ;; a time but instead it can skip numbers. Since this is not visible by ;; the user, and just used as a token in the URL, it's okay as long as ;; compiling the same file twice gives the same numbers (which is ;; hopefully the case but hasn't been tested). + (free-identifier-mapping-put! repeat-chunk-numbers id (add1 current)) current))) (require (for-syntax "no-auto-require.rkt")) @@ -104,15 +109,16 @@ #,@(if (null? (syntax-e #'(for-label-mod ... ...))) #'() #'((require (for-label for-label-mod ... ...))))))])) - + (define-for-syntax ((make-chunk-display racketblock) stx) (syntax-parse stx ;; no need for more error checking, using chunk for the code will do that [(_ original-name:id name:id stxn:number expr ...) (define n (syntax-e #'stxn)) + (define original-name:n (syntax-local-introduce + (format-id #'original-name "~a:~a" #'original-name n))) (define n-repeat (get+increment-repeat-chunk-number! - (syntax-local-introduce - (format-id #'name "~a:~a" #'name n)))) + original-name:n)) (define str (string-append (symbol->string (syntax-e #'name)))) (define/with-syntax tag (format "chunk:~a:~a:~a" str n n-repeat)) (define/with-syntax (rest ...) @@ -124,25 +130,33 @@ (and c (> c 2))) #`((subscript #,(format "~a" n))) #'())) - #`(make-splice - (list (make-toc-element - #f - (list (elemtag '(prefixable tag) - (bold (italic (elemref '(prefixable tag) - #:underline? #f - #,str rest ...)) - " ::="))) - (list (smaller (elemref '(prefixable tag) #:underline? #f - #,str - rest ...)))) - (#,racketblock expr ...)))])) + ;; The (list) here could be important, to avoid the code being + ;; executed multiple times in weird ways, when pre-expanding. + #`(list + (make-splice + (list (make-toc-element + #f + (list (elemtag '(prefixable tag) + (bold (italic (elemref '(prefixable tag) + #:underline? #f + #,str rest ...)) + " ::="))) + (list (smaller (elemref '(prefixable tag) #:underline? #f + #,str + rest ...)))) + (#,racketblock expr ...))))])) (define-for-syntax (make-chunk chunk-code chunk-display) (syntax-parser ;; no need for more error checking, using chunk for the code will do that [(_ (~optional (~seq #:save-as save-as:id)) name:id expr ...) (define n (get-chunk-number (syntax-local-introduce #'name))) - (define str (symbol->string (syntax-e #'name))) + (define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1))) + + (define/with-syntax stripped-name + (regexp-replace #px"^<(.*)>$" + (symbol->string (syntax-e #'name)) + "\\1")) (when n (inc-chunk-number (syntax-local-introduce #'name))) @@ -159,21 +173,41 @@ (lambda (stx) #'(chunkref name)))) (begin-for-syntax (init-chunk-number #'name)))) #,(if (attribute save-as) - #'(define-syntax (save-as s) - (syntax-case s () - [(_) - #`(save-as #,(syntax-local-introduce - (quote-syntax name)))] - [(_ newname) - #`(stx-chunk-display - #,(syntax-local-introduce - (quote-syntax name)) - newname - stx-n - #,@(syntax-local-introduce - (quote-syntax (expr ...))))])) - ;; The (list) here is important, to avoid the code being executed - ;; multiple times in weird ways, when pre-expanding. + #`(begin + #,#'(define-syntax (do-for-syntax _) + (init-repeat-chunk-number (quote-syntax name:n)) + #'(void)) + (do-for-syntax) + (define-syntax (save-as s) + (syntax-case s () + [(_) + (let* ([local-name (syntax-local-introduce + (quote-syntax name))] + [local-name:n (syntax-local-introduce + (quote-syntax name:n))] + [n-repeat (get-repeat-chunk-number + local-name:n)]) + (with-syntax + ([name-maybe-paren (if (> n-repeat 1) + (format-id local-name + "(~a)" + stripped-name) + local-name)]) + #'(save-as name-maybe-paren)))] + [(_ newname) + (with-syntax ([local-name + (syntax-local-introduce + (quote-syntax name))] + [(local-expr (... ...)) + (syntax-local-introduce + (quote-syntax (expr ...)))]) + #`(stx-chunk-display + local-name + newname + stx-n + local-expr (... ...)))]))) + ;; The (list) here could be important, to avoid the code being + ;; executed multiple times in weird ways, when pre-expanding. #`(list (stx-chunk-display name name stx-n expr ...))))])) (define-syntax chunk-code (make-chunk-code #t))