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

Add CHUNK

Browse Source 
original commit: 05128592353ba81d378afb55ebb9724cfd8aecc4
This commit is contained in:
Jay McCarthy 2013-07-22 09:45:41 -06:00
parent 4448ccae6b
commit 8a8a54fec9
3 changed files with 53 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/scribble-pkgs/scribble-lib/scribble/lp-include.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/include (for-syntax scheme/base) (require scheme/include (for-syntax scheme/base)
(only-in scribble/private/lp chunk) (only-in scribble/private/lp chunk CHUNK)
scribble/manual) scribble/manual)
(provide lp-include) (provide lp-include)

2
pkgs/scribble-pkgs/scribble-lib/scribble/lp.rkt
View File

@ -1,3 +1,3 @@
#lang racket/base #lang racket/base
(require scribble/private/lp) (require scribble/private/lp)
(provide chunk) (provide chunk CHUNK)

90
pkgs/scribble-pkgs/scribble-lib/scribble/private/lp.rkt
View File

@ -14,58 +14,62 @@
(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-syntax (chunk stx) (define-syntax-rule (define-chunk chunk-id racketblock)
(syntax-case stx () (define-syntax (chunk-id stx)
[(_ name expr ...) (syntax-case stx ()
;; no need for more error checking, using chunk for the code will do that [(_ name expr (... ...))
(identifier? #'name) ;; no need for more error checking, using chunk for the code will do that
(let* ([n (get-chunk-number (syntax-local-introduce #'name))] (identifier? #'name)
[str (symbol->string (syntax-e #'name))] (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
[tag (format "~a:~a" str (or n 1))]) [str (symbol->string (syntax-e #'name))]
[tag (format "~a:~a" str (or n 1))])
(when n (when n
(inc-chunk-number (syntax-local-introduce #'name))) (inc-chunk-number (syntax-local-introduce #'name)))
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...))))
(with-syntax ([tag tag] (with-syntax ([tag tag]
[str str] [str str]
[((for-label-mod ...) ...) [((for-label-mod (... ...)) (... ...))
(map (lambda (expr) (map (lambda (expr)
(syntax-case expr (require) (syntax-case expr (require)
[(require mod ...) [(require mod (... ...))
(let loop ([mods (syntax->list #'(mod ...))]) (let loop ([mods (syntax->list #'(mod (... ...)))])
(cond (cond
[(null? mods) null] [(null? mods) null]
[else [else
(syntax-case (car mods) (for-syntax) (syntax-case (car mods) (for-syntax)
[(for-syntax x ...) [(for-syntax x (... ...))
(append (loop (syntax->list #'(x ...))) (append (loop (syntax->list #'(x (... ...))))
(loop (cdr mods)))] (loop (cdr mods)))]
[x [x
(cons #'x (loop (cdr mods)))])]))] (cons #'x (loop (cdr mods)))])]))]
[else null])) [else null]))
(syntax->list #'(expr ...)))] (syntax->list #'(expr (... ...))))]
[(rest ...) (if n [(rest (... ...)) (if n
#`((subscript #,(format "~a" n))) #`((subscript #,(format "~a" n)))
#`())]) #`())])
#`(begin #`(begin
(require (for-label for-label-mod ... ...)) (require (for-label for-label-mod (... ...) (... ...)))
#,@(if n #,@(if n
#'() #'()
#'((define-syntax name (make-element-id-transformer #'((define-syntax name (make-element-id-transformer
(lambda (stx) #'(chunkref name)))) (lambda (stx) #'(chunkref name))))
(begin-for-syntax (init-chunk-number #'name)))) (begin-for-syntax (init-chunk-number #'name))))
(make-splice (make-splice
(list (make-toc-element (list (make-toc-element
#f #f
(list (elemtag '(chunk tag) (list (elemtag '(chunk tag)
(bold (italic (racket name)) " ::="))) (bold (italic (racket name)) " ::=")))
(list (smaller (elemref '(chunk tag) #:underline? #f (list (smaller (elemref '(chunk tag) #:underline? #f
str str
rest ...)))) rest (... ...)))))
(racketblock expr ...))))))])) (racketblock expr (... ...)))))))])))
(define-chunk chunk racketblock)
(define-chunk CHUNK RACKETBLOCK)
(define-syntax (chunkref stx) (define-syntax (chunkref stx)
(syntax-case stx () (syntax-case stx ()
@ -78,4 +82,4 @@
(provide (all-from-out scheme/base (provide (all-from-out scheme/base
scribble/manual) scribble/manual)
chunk) chunk CHUNK)