From fe2b582def904d48cd03667c67404eba04981985 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 20 Sep 2016 03:12:58 +0200 Subject: [PATCH] Cleaned up the definition of @chunk and @CHUNK. Fixed issues with subscript numbers on chunks, links, and conflicting tags. Now it's possible to re-print a chunk several times without problem. --- main.rkt | 2 +- private/common.rkt | 5 +- private/lp.rkt | 261 +++++++++++++++++++++++++++------------------ 3 files changed, 161 insertions(+), 107 deletions(-) diff --git a/main.rkt b/main.rkt index 64f3da67..b22559ac 100644 --- a/main.rkt +++ b/main.rkt @@ -35,4 +35,4 @@ (with-syntax ([chk (datum->syntax #'self 'chunk)] [name2 (format-id #'name "~a-repeat" #'name)] [name-rep (format-id #'name "(~a)" stripped-name)]) - #'(name2 chk name-rep)))])) \ No newline at end of file + #'(name2 chk name-rep)))])) diff --git a/private/common.rkt b/private/common.rkt index b241b277..c41a72b7 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -221,10 +221,7 @@ (define-syntax-rule (unless-preexpanding . b) (begin . b)) - (require (only-in racket/require - subtract-in) - (subtract-in scribble/manual - scribble-enhanced) + (require scribble-enhanced/with-manual scribble-enhanced hyper-literate)))) (begn body0 . body)) diff --git a/private/lp.rkt b/private/lp.rkt index f6856911..894c1817 100644 --- a/private/lp.rkt +++ b/private/lp.rkt @@ -18,119 +18,176 @@ chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) (define (init-chunk-number id) - (free-identifier-mapping-put! chunk-numbers id 2))) + (free-identifier-mapping-put! chunk-numbers id 2)) + + (define repeat-chunk-numbers (make-free-identifier-mapping)) + (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). + current))) (require (for-syntax "no-auto-require.rkt")) -(define-for-syntax ((make-chunk racketblock unsyntax?) stx) +(define-for-syntax (make-chunk-code unsyntax?) + (syntax-parser + ;; no need for more error checking, using chunk for the code will do that + [(_ name:id expr ...) + + ;; Lift the code so that it is caught by `extract-chunks` in common.rkt + ;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) + + ;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax + ;; escapes the chunk so that code can be injected at compile-time. + ;; The identifiers inside the escaped portion need to be available both + ;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the + ;; underlying @racketblock expands the code at run-time, but the + ;; extract-chunks function in common.rkt looks at the expanded source + ;; code. + ;; For now, only #, i.e. unsyntax is supported, within @chunk. + ;; Later support for UNSYNTAX within @CHUNK may be added. + (define expand-unsyntax + (if unsyntax? + ;; New hack: + #'((define-syntax (macro-to-expand-unsyntax _) + (define a #'here) + (define b (syntax-local-identifier-as-binding + (syntax-local-introduce #'here))) + (define intr (make-syntax-delta-introducer b a)) + (syntax-local-lift-expression + (intr #'(quote-syntax (a-chunk ((... ...) name) + ((... ...) expr) ...)) + 'flip)) + #'(void)) + (macro-to-expand-unsyntax)) + ;; Default (old) behaviour, does not support escaping via #, + (begin (syntax-local-lift-expression + #'(quote-syntax (a-chunk name expr ...))) + #f))) + + (with-syntax + ;; Extract require forms + ([((for-label-mod ...) ...) + (if (unbox no-auto-require?) + #'() + (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 ...))))]) + #`(begin + #,@(if expand-unsyntax expand-unsyntax #'()) + #,@(if (null? (syntax-e #'(for-label-mod ... ...))) + #'() + #'((require (for-label for-label-mod ... ...))))))])) + +(define-for-syntax ((make-chunk-display racketblock) stx) (syntax-parse stx - [(_ (~optional (~seq #:save-as save-as)) 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 "chunk:~a:~a" str (or n 1))]) + ;; 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 n-repeat (get+increment-repeat-chunk-number! + (syntax-local-introduce + (format-id #'name "~a:~a" #'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 ...) + ;; if the would-be-next number for this chunk name is "2", then there is + ;; only one chunk, whose number is "1". Otherwise, if the number is 3 or + ;; more, it means that the chunk with number "2" exists, so we should + ;; display the subscript numbers. + (if (let ([c (get-chunk-number #'original-name)]) + (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 ...)))])) + +(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))) - (when n - (inc-chunk-number (syntax-local-introduce #'name))) + (when n + (inc-chunk-number (syntax-local-introduce #'name))) - ;; Lift the code so that it is caught by `extract-chunks` in common.rkt - ;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) - - ;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax - ;; escapes the chunk so that code can be injected at compile-time. - ;; The identifiers inside the escaped portion need to be available both - ;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the - ;; underlying @racketblock expands the code at run-time, but the - ;; extract-chunks function in common.rkt looks at the expanded source - ;; code. - ;; For now, only #, i.e. unsyntax is supported, within @chunk. - ;; Later support for UNSYNTAX within @CHUNK may be added. - (define expand-unsyntax - (if unsyntax? - ;; New hack: - #'((define-syntax (macro-to-expand-unsyntax _) - (define a #'here) - (define b (syntax-local-identifier-as-binding - (syntax-local-introduce #'here))) - (define intr (make-syntax-delta-introducer b a)) - (syntax-local-lift-expression - (intr #`(quote-syntax (a-chunk ((... ...) name) - ((... ...) expr) ...)) - 'flip)) - #'(void)) - (macro-to-expand-unsyntax)) - ;; Default (old) behaviour, which does not support escaping via #, - (begin (syntax-local-lift-expression - #'(quote-syntax (a-chunk name expr ...))) - #f))) + (define/with-syntax stx-n (or n 1)) + (define/with-syntax stx-chunk-code chunk-code) + (define/with-syntax stx-chunk-display chunk-display) + + #`(begin + (stx-chunk-code name expr ...) + #,@(if n + #'() + #'((define-syntax name (make-element-id-transformer + (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. + #`(list (stx-chunk-display name name stx-n expr ...))))])) - - ;; Extract require forms - (with-syntax ([tag tag] - [str str] - [((for-label-mod ...) ...) - (if (unbox no-auto-require?) - #'() - (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))) - #`())]) - (define/with-syntax pre-content - #`(make-splice - (list (make-toc-element - #f - (list (elemtag '(prefixable tag) - (bold (italic (racket name)) " ::="))) - (list (smaller (elemref '(prefixable tag) #:underline? #f - str - rest ...)))) - (#,racketblock expr ...)))) - #`(begin - #,@(if expand-unsyntax expand-unsyntax #'()) - #,@(if (null? (syntax-e #'(for-label-mod ... ...))) - #'() - #'((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)))) - #,(if (attribute save-as) - #'(define-syntax (save-as s) (quote-syntax pre-content)) - #'pre-content))))])) - -(define-syntax chunk (make-chunk #'racketblock #t)) -(define-syntax CHUNK (make-chunk #'RACKETBLOCK #f)) +(define-syntax chunk-code (make-chunk-code #t)) +(define-syntax CHUNK-code (make-chunk-code #f)) +(define-syntax chunk-display (make-chunk-display #'racketblock)) +(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK)) +(define-syntax chunk (make-chunk #'chunk-code #'chunk-display)) +(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display)) (define-syntax (chunkref stx) (syntax-case stx () [(_ id) (identifier? #'id) - (with-syntax ([tag (format "chunk:~a:1" (syntax-e #'id))] + (with-syntax ([tag (format "chunk:~a:1:1" (syntax-e #'id))] [str (format "~a" (syntax-e #'id))]) #'(elemref '(prefixable tag) #:underline? #f str))]))