Skip to content

Commit

Permalink
Fixed scribble bug racket#15. Also cleaned up code by currying the ra…
Browse files Browse the repository at this point in the history
…cketblock vs RACKETBLOCK parameter for chunk and CHUNK instead of calling define-syntax-rule twice.
  • Loading branch information
SuzanneSoy committed Jun 17, 2016
1 parent 1b15bce commit be223ef
Showing 1 changed file with 58 additions and 54 deletions.
112 changes: 58 additions & 54 deletions typed/private/lp.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -15,62 +15,68 @@
(define (init-chunk-number id)
(free-identifier-mapping-put! chunk-numbers id 2)))

(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
(define-for-syntax ((make-chunk racketblock) 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 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)))
#`())])
#`(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 chunk (make-chunk #'racketblock))
(define-syntax CHUNK (make-chunk #'RACKETBLOCK))

(define-syntax (chunkref stx)
(syntax-case stx ()
Expand All @@ -81,8 +87,6 @@
#'(elemref '(chunk tag) #:underline? #f str))]))


(require typed/racket/base)

(provide (all-from-out typed/racket/base ;scheme/base
(provide (all-from-out scheme/base
scribble/manual)
chunk CHUNK)

0 comments on commit be223ef

Please sign in to comment.