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
(require scheme/include (for-syntax scheme/base)
(only-in scribble/private/lp chunk)
(only-in scribble/private/lp chunk CHUNK)
scribble/manual)
(provide lp-include)

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

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

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

@ -14,58 +14,62 @@
(define (init-chunk-number id)
(free-identifier-mapping-put! chunk-numbers id 2)))
(define-syntax (chunk 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
(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
#`(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 (chunkref stx)
(syntax-case stx ()
@ -78,4 +82,4 @@
(provide (all-from-out scheme/base
scribble/manual)
chunk)
chunk CHUNK)