suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

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.

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-20 03:12:58 +02:00
parent 148ec8da08
commit fe2b582def
3 changed files with 161 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
main.rkt
View File

@ -35,4 +35,4 @@
(with-syntax ([chk (datum->syntax #'self 'chunk)] (with-syntax ([chk (datum->syntax #'self 'chunk)]
[name2 (format-id #'name "~a-repeat" #'name)] [name2 (format-id #'name "~a-repeat" #'name)]
[name-rep (format-id #'name "(~a)" stripped-name)]) [name-rep (format-id #'name "(~a)" stripped-name)])
#'(name2 chk name-rep)))])) #'(name2 chk name-rep)))]))

5
private/common.rkt
View File

@ -221,10 +221,7 @@
(define-syntax-rule (define-syntax-rule
(unless-preexpanding . b) (unless-preexpanding . b)
(begin . b)) (begin . b))
(require (only-in racket/require (require scribble-enhanced/with-manual
subtract-in)
(subtract-in scribble/manual
scribble-enhanced)
scribble-enhanced scribble-enhanced
hyper-literate)))) hyper-literate))))
(begn body0 . body)) (begn body0 . body))

261
private/lp.rkt
View File

@ -18,119 +18,176 @@
chunk-numbers id chunk-numbers id
(+ 1 (free-identifier-mapping-get chunk-numbers id)))) (+ 1 (free-identifier-mapping-get chunk-numbers id))))
(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 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")) (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 (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
;; no need for more error checking, using chunk for the code will do that [(_ original-name:id name:id stxn:number expr ...)
(identifier? #'name) (define n (syntax-e #'stxn))
(let* ([n (get-chunk-number (syntax-local-introduce #'name))] (define n-repeat (get+increment-repeat-chunk-number!
[str (symbol->string (syntax-e #'name))] (syntax-local-introduce
[tag (format "chunk:~a:~a" str (or n 1))]) (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 (when n
(inc-chunk-number (syntax-local-introduce #'name))) (inc-chunk-number (syntax-local-introduce #'name)))
;; Lift the code so that it is caught by `extract-chunks` in common.rkt (define/with-syntax stx-n (or n 1))
;(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) (define/with-syntax stx-chunk-code chunk-code)
(define/with-syntax stx-chunk-display chunk-display)
;; Convoluted trick to allow unsyntax in chunks of code. The unsyntax
;; escapes the chunk so that code can be injected at compile-time. #`(begin
;; The identifiers inside the escaped portion need to be available both (stx-chunk-code name expr ...)
;; for-syntax i.e. (for-meta 1) and (for-meta 0). This is because the #,@(if n
;; underlying @racketblock expands the code at run-time, but the #'()
;; extract-chunks function in common.rkt looks at the expanded source #'((define-syntax name (make-element-id-transformer
;; code. (lambda (stx) #'(chunkref name))))
;; For now, only #, i.e. unsyntax is supported, within @chunk. (begin-for-syntax (init-chunk-number #'name))))
;; Later support for UNSYNTAX within @CHUNK may be added. #,(if (attribute save-as)
(define expand-unsyntax #'(define-syntax (save-as s)
(if unsyntax? (syntax-case s ()
;; New hack: [(_)
#'((define-syntax (macro-to-expand-unsyntax _) #`(save-as #,(syntax-local-introduce
(define a #'here) (quote-syntax name)))]
(define b (syntax-local-identifier-as-binding [(_ newname)
(syntax-local-introduce #'here))) #`(stx-chunk-display
(define intr (make-syntax-delta-introducer b a)) #,(syntax-local-introduce
(syntax-local-lift-expression (quote-syntax name))
(intr #`(quote-syntax (a-chunk ((... ...) name) newname
((... ...) expr) ...)) stx-n
'flip)) #,@(syntax-local-introduce
#'(void)) (quote-syntax (expr ...))))]))
(macro-to-expand-unsyntax)) ;; The (list) here is important, to avoid the code being executed
;; Default (old) behaviour, which does not support escaping via #, ;; multiple times in weird ways, when pre-expanding.
(begin (syntax-local-lift-expression #`(list (stx-chunk-display name name stx-n expr ...))))]))
#'(quote-syntax (a-chunk name expr ...)))
#f)))
(define-syntax chunk-code (make-chunk-code #t))
;; Extract require forms (define-syntax CHUNK-code (make-chunk-code #f))
(with-syntax ([tag tag] (define-syntax chunk-display (make-chunk-display #'racketblock))
[str str] (define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK))
[((for-label-mod ...) ...) (define-syntax chunk (make-chunk #'chunk-code #'chunk-display))
(if (unbox no-auto-require?) (define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))
#'()
(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 (chunkref stx) (define-syntax (chunkref stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
(identifier? #'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))]) [str (format "~a" (syntax-e #'id))])
#'(elemref '(prefixable tag) #:underline? #f str))])) #'(elemref '(prefixable tag) #:underline? #f str))]))