suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Some styling.

Browse Source 
original commit: 75f710dc62c8c5a1ce04f22b6c37a4c611a3445e
This commit is contained in:
Eli Barzilay 2012-07-01 01:30:03 -04:00
parent 9650c4767b
commit 5cb1ba3a4a
3 changed files with 137 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/scribble/html/resource.rkt
View File

@ -22,7 +22,7 @@
;; resource that uses this value. Creating a resource registers the `renderer' ;; resource that uses this value. Creating a resource registers the `renderer'
;; to be executed when rendering is initiated by `render-all'. Note that more ;; to be executed when rendering is initiated by `render-all'. Note that more
;; resources can be created while rendering; they will also be rendered in turn ;; resources can be created while rendering; they will also be rendered in turn
;; until no more resources are created. ;; until no more new resources are created.
(require scribble/text) (require scribble/text)
@ -34,12 +34,13 @@
(define rendered-dirpath (make-parameter '())) (define rendered-dirpath (make-parameter '()))
;; A mapping from path prefixes to urls (actually, any string) -- when two ;; A mapping from path prefixes to urls (actually, any string) -- when two
;; paths are in the same prefix, links from one to the other are relative, but ;; paths are in the same prefix, links from one to the other are relative
;; if they're in different prefixes, the url will be used instead; the roots ;; (unless absolute links are requested) , but if they're in different
;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots). ;; prefixes, the url will be used instead; the roots are expected to be
;; Additionally, optional symbol flags can appear in each entry, currently only ;; disjoint (= no "/foo" and "/foo/bar" roots). Additionally, optional symbol
;; 'abs is used below for roots that should always use absolute links (needed ;; flags can appear in each entry, currently only 'abs is used below for roots
;; for some skeleton pages that are used in nested subdirectories). ;; that should always use absolute links (needed for some skeleton pages that
;; are used in nested subdirectories).
(provide url-roots) (provide url-roots)
(define url-roots (make-parameter #f)) (define url-roots (make-parameter #f))

220
collects/scribble/text/output.rkt
View File

@ -4,7 +4,7 @@
(provide output) (provide output)
;; Outputs some value for the `scribble/text' language: ;; Outputs values for the `scribble/text' language:
;; - several atomic values are printed as in `display', ;; - several atomic values are printed as in `display',
;; - promises, thunks, and boxes are indirections for the value they contain ;; - promises, thunks, and boxes are indirections for the value they contain
;; (useful in various cases), ;; (useful in various cases),
@ -87,12 +87,12 @@
[nls (regexp-match-positions* #rx"\n" x)]) [nls (regexp-match-positions* #rx"\n" x)])
(let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)])
(cond [(pair? nls) (cond [(pair? nls)
(let ([nl (car nls)]) (define nl (car nls))
(if (regexp-match? #rx"^ *$" x start (car nl)) (if (regexp-match? #rx"^ *$" x start (car nl))
(newline p) ; only spaces before the end of the line (newline p) ; only spaces before the end of the line
(begin (output-pfx col pfx lpfx) (begin (output-pfx col pfx lpfx)
(write x p start (cdr nl)))) (write x p start (cdr nl))))
(loop (cdr nl) (cdr nls) 0 0))] (loop (cdr nl) (cdr nls) 0 0)]
;; last substring from here (always set lpfx state when done) ;; last substring from here (always set lpfx state when done)
[(start . = . len) [(start . = . len)
(set-mcdr! pfxs lpfx)] (set-mcdr! pfxs lpfx)]
@ -101,23 +101,24 @@
;; the prefix was already shown, no accumulation needed ;; the prefix was already shown, no accumulation needed
(write x p start)] (write x p start)]
[else [else
(let ([m (regexp-match-positions #rx"^ +" x start)]) (define m (regexp-match-positions #rx"^ +" x start))
;; accumulate spaces to lpfx, display if it's not all spaces ;; accumulate spaces to lpfx, display if it's not all spaces
(let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)]) (define lpfx* (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx))
(set-mcdr! pfxs lpfx) (set-mcdr! pfxs lpfx*)
(unless (and m (= len (cdar m))) (unless (and m (= len (cdar m)))
(output-pfx col pfx lpfx) (output-pfx col pfx lpfx*)
;; the spaces were already added to lpfx ;; the spaces were already added to lpfx
(write x p (if m (cdar m) start)))))]))))) (write x p (if m (cdar m) start)))])))))
;; blocks and splices ;; blocks and splices
(define (output-block c) (define (output-block c)
(let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] (define pfx (mcar pfxs))
[npfx (pfx+col (pfx+ pfx lpfx))]) (define lpfx (mcdr pfxs))
(set-mcar! pfxs npfx) (set-mcdr! pfxs 0) (define npfx (pfx+col (pfx+ pfx lpfx)))
(if (list? c) (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
(for ([c (in-list c)]) (loop c)) (if (list? c)
(begin (loop (car c)) (loop (cdr c)))) (for ([c (in-list c)]) (loop c))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))) (begin (loop (car c)) (loop (cdr c))))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))
(define (output-splice c) (define (output-splice c)
(for-each loop c)) (for-each loop c))
;; main loop ;; main loop
@ -136,92 +137,97 @@
[(box? x) (loop (unbox x))] [(box? x) (loop (unbox x))]
;; special output wrappers ;; special output wrappers
[(special? x) [(special? x)
(let ([c (special-contents x)]) (define c (special-contents x))
(case (special-flag x) (case (special-flag x)
;; preserve tailness & avoid `set!' for blocks/splices if possible ;; preserve tailness & avoid `set!' for blocks/splices if possible
[(block) (if list=block? [(block) (if list=block?
(output-block c) (output-block c)
(begin (set! list=block? #t) (begin (set! list=block? #t)
(output-block c) (output-block c)
(set! list=block? #f)))] (set! list=block? #f)))]
[(splice) (if list=block? [(splice) (if list=block?
(begin (set! list=block? #f) (begin (set! list=block? #f)
(output-splice c) (output-splice c)
(set! list=block? #t)) (set! list=block? #t))
(output-splice c))] (output-splice c))]
[(flush) ; useful before `disable-prefix' [(flush) ; useful before `disable-prefix'
(output-pfx (getcol) (mcar pfxs) (mcdr pfxs))] (output-pfx (getcol) (mcar pfxs) (mcdr pfxs))]
[(disable-prefix) ; save the previous pfxs [(disable-prefix) ; save the previous pfxs
(let ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]) (define pfx (mcar pfxs))
(set-mcar! pfxs #f) (set-mcdr! pfxs (cons pfx lpfx)) (define lpfx (mcdr pfxs))
(for-each loop c) (set-mcar! pfxs #f) (set-mcdr! pfxs (cons pfx lpfx))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] (for-each loop c)
[(restore-prefix) ; restore the previous pfxs (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)]
(let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] [(restore-prefix) ; restore the previous pfxs
[npfx (pfx+col (if (and (not pfx) (pair? lpfx)) (define pfx (mcar pfxs))
(pfx+ (car lpfx) (cdr lpfx)) (define lpfx (mcdr pfxs))
(pfx+ pfx lpfx)))]) (define npfx (pfx+col (if (and (not pfx) (pair? lpfx))
(set-mcar! pfxs npfx) (set-mcdr! pfxs 0) (pfx+ (car lpfx) (cdr lpfx))
(for-each loop c) (pfx+ pfx lpfx))))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
[(add-prefix) ; add to the current prefix (unless it's #f) (for-each loop c)
(let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)]
[npfx (pfx+ (pfx+col (pfx+ pfx lpfx)) (car c))]) [(add-prefix) ; add to the current prefix (unless it's #f)
(set-mcar! pfxs npfx) (set-mcdr! pfxs 0) (define pfx (mcar pfxs))
(for-each loop (cdr c)) (define lpfx (mcdr pfxs))
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] (define npfx (pfx+ (pfx+col (pfx+ pfx lpfx)) (car c)))
[(set-prefix) (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
(let ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]) (for-each loop (cdr c))
(set-mcar! pfxs (car c)) (set-mcdr! pfxs 0) (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)]
(for-each loop (cdr c)) [(set-prefix)
(set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] (define pfx (mcar pfxs))
[(with-writer) (define lpfx (mcdr pfxs))
(let ([old write]) (set-mcar! pfxs (car c)) (set-mcdr! pfxs 0)
(set! write (or (car c) write-string)) (for-each loop (cdr c))
(for-each loop (cdr c)) (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)]
(set! write old))] [(with-writer)
#; ; no need for this hack yet (define old write)
[(with-writer-change) (set! write (or (car c) write-string))
;; The function gets the old writer and return a new one (useful to (for-each loop (cdr c))
;; save the current writer and restore it inside). Could also be (set! write old)]
;; used to extend a writer, but that shows why a customizable #; ; no need for this hack yet
;; writer is a bad choice: instead, it should be a list of [(with-writer-change)
;; substitutions that can be extended more conveniently. A simple ;; The function gets the old writer and return a new one (useful to
;; implementation would be to chain functions that do ;; save the current writer and restore it inside). Could also be
;; substitutions. But that runs into problems when functions want ;; used to extend a writer, but that shows why a customizable writer
;; to substitute the same thing, and worse: when the output of one ;; is a bad choice: instead, it should be a list of substitutions
;; function would get substituted again by another. Another ;; that can be extended more conveniently. A simple implementation
;; approach would be to join matcher regexps with "|" after ;; would be to chain functions that do substitutions. But that runs
;; wrapping each one with parens, then find out which one matched ;; into problems when functions want to substitute the same thing,
;; by looking at the result and applying its substitution, but the ;; and worse: when the output of one function would get substituted
;; problem with that is that is that it forbids having parens in ;; again by another. Another approach would be to join matcher
;; the regexps -- this could be fixed by not parenthesizing each ;; regexps with "|" after wrapping each one with parens, then find
;; expression, and instead running the found match against each of ;; out which one matched by looking at the result and applying its
;; the input regexps to find the matching one, but that can be very ;; substitution, but the problem with that is that is that it forbids
;; inefficient. Yet another issue is that in some cases we might ;; having parens in the regexps -- this could be fixed by not
;; *want* the "worse" feature mentioned earlier: for example, when ;; parenthesizing each expression, and instead running the found
;; we want to do some massaging of the input texts yet still have ;; match against each of the input regexps to find the matching one,
;; the result encoded for HTML output -- so perhaps the simple ;; but that can be very inefficient. Yet another issue is that in
;; approach is still better. The only difference from the current ;; some cases we might *want* the "worse" feature mentioned earlier:
;; `with-writer' is using a substituting function, so it can be ;; for example, when we want to do some massaging of the input texts
;; composed with the current one instead of replacing it ;; yet still have the result encoded for HTML output -- so perhaps
;; completely. ;; the simple approach is still better. The only difference from the
(let ([old write]) ;; current `with-writer' is using a substituting function, so it can
(set! write ((car c) write)) ;; be composed with the current one instead of replacing it
(for-each loop (cdr c)) ;; completely.
(set! write old))] (define old write)
[else (error 'output "unknown special value flag: ~e" (set! write ((car c) write))
(special-flag x))]))] (for-each loop (cdr c))
(set! write old)]
[else (error 'output "unknown special value flag: ~e"
(special-flag x))])]
[else [else
(output-string (output-string
(cond [(string? x) x] (cond [(string? x) x]
[(bytes? x) (bytes->string/utf-8 x)] [(bytes? x) (bytes->string/utf-8 x)]
[(symbol? x) (symbol->string x)] [(symbol? x) (symbol->string x)]
[(path? x) (path->string x)] [(path? x) (path->string x)]
[(keyword? x) (keyword->string x)] [(keyword? x) (keyword->string x)]
[(number? x) (number->string x)] [(number? x) (number->string x)]
[(char? x) (string x)] [(char? x) (string x)]
;; generic fallback: throw an error ;; generic fallback: throw an error (could use `display' so new
;; values can define how they're shown, but the same
;; functionality can be achieved with thunks and prop:procedure)
[else (error 'output "don't know how to render value: ~v" x)]))])) [else (error 'output "don't know how to render value: ~v" x)]))]))
;; ;;
(port-count-lines! p) (port-count-lines! p)
@ -231,7 +237,7 @@
(define port->state (define port->state
(let ([t (make-weak-hasheq)] (let ([t (make-weak-hasheq)]
[last '(#f #f)]) ; cache for the last port, to avoid a hash lookup [last '(#f #f)]) ; cache for the last port, to avoid a hash lookup
(lambda (p) (λ (p)
(if (eq? p (car last)) (cdr last) (if (eq? p (car last)) (cdr last)
(let ([s (or (hash-ref t p #f) (let ([s (or (hash-ref t p #f)
(let ([s (mcons 0 0)]) (hash-set! t p s) s))]) (let ([s (mcons 0 0)]) (hash-set! t p s) s))])
@ -269,7 +275,7 @@
(define make-spaces ; (efficiently) (define make-spaces ; (efficiently)
(let ([t (make-hasheq)] [v (make-vector 200 #f)]) (let ([t (make-hasheq)] [v (make-vector 200 #f)])
(lambda (n) (λ (n)
(or (if (< n 200) (vector-ref v n) (hash-ref t n #f)) (or (if (< n 200) (vector-ref v n) (hash-ref t n #f))
(let ([spaces (make-string n #\space)]) (let ([spaces (make-string n #\space)])
(if (< n 200) (vector-set! v n spaces) (hash-set! t n spaces)) (if (< n 200) (vector-set! v n spaces) (hash-set! t n spaces))

32
collects/scribble/text/syntax-utils.rkt
View File

@ -12,7 +12,7 @@
(define stoplist (append definition-ids (kernel-form-identifier-list))) (define stoplist (append definition-ids (kernel-form-identifier-list)))
(define (definition-id? id) (define (definition-id? id)
(and (identifier? id) (and (identifier? id)
(ormap (lambda (i) (free-identifier=? id i)) definition-ids))) (ormap (λ (i) (free-identifier=? id i)) definition-ids)))
(define (definition? x) (define (definition? x)
(syntax-case x () [(id . rest) (and (definition-id? #'id) #'id)] [_ #f])) (syntax-case x () [(id . rest) (and (definition-id? #'id) #'id)] [_ #f]))
(define (begin?->list x) (define (begin?->list x)
@ -34,20 +34,20 @@
[(or cur (pair? after)) (loop xs '() x '() (add))] [(or cur (pair? after)) (loop xs '() x '() (add))]
[else (loop xs before x '() r)]))))) [else (loop xs before x '() r)])))))
(define (group-stxs stxs fun) (define (group-stxs stxs fun)
(group-by (lambda (stx) (group-by (λ (stx)
(let ([p (syntax-property stx 'scribble)]) (define p (syntax-property stx 'scribble))
(cond [(and (pair? p) (eq? (car p) 'newline)) '>] (cond [(and (pair? p) (eq? (car p) 'newline)) '>]
[(eq? 'indentation p) '<] [(eq? 'indentation p) '<]
[else #f]))) [else #f]))
stxs fun)) stxs fun))
#; ; tests for this #; ; tests for this
(for-each (for-each
(lambda (t) (λ (t)
(let ([r (group-by (lambda (x) (define r (group-by (λ (x)
(cond [(number? x) '<] [(symbol? x) '>] [else #f])) (cond [(number? x) '<] [(symbol? x) '>] [else #f]))
(car t) (car t)
list)]) list))
(unless (equal? r (cadr t)) (printf "FAILURE: ~s -> ~s\n" (car t) r)))) (unless (equal? r (cadr t)) (printf "FAILURE: ~s -> ~s\n" (car t) r)))
'([() ()] '([() ()]
[("a") ((() "a" ()))] [("a") ((() "a" ()))]
[("a" "b") ((() "a" ()) (() "b" ()))] [("a" "b") ((() "a" ()) (() "b" ()))]
@ -83,7 +83,7 @@
#,@(if post? #'((decor 'post) ...) #'())) #,@(if post? #'((decor 'post) ...) #'()))
expr)) expr))
(cond [(begin?->list expr*) (cond [(begin?->list expr*)
=> (lambda (xs) => (λ (xs)
(if (null? xs) (if (null? xs)
(if (or pre? post?) (if (or pre? post?)
#'(begin (decor 'pre) ... (decor 'post) ...) #'(begin (decor 'pre) ... (decor 'post) ...)
@ -97,7 +97,7 @@
(define (process-body decor body) (define (process-body decor body)
(group-stxs (group-stxs
(syntax->list body) (syntax->list body)
(lambda (pre expr post) (λ (pre expr post)
(with-syntax ([decor decor]) (with-syntax ([decor decor])
(if (not expr) ; no need to decorate these (if (not expr) ; no need to decorate these
(with-syntax ([(x ...) (append pre post)]) #`(decor '(x ...))) (with-syntax ([(x ...) (append pre post)]) #`(decor '(x ...)))
@ -146,7 +146,7 @@
(values (reverse ds) (reverse es) exprs))] (values (reverse ds) (reverse es) exprs))]
[_ (loop (cdr exprs) ds (cons expr* es))]))))) [_ (loop (cdr exprs) ds (cons expr* es))])))))
(define-syntax (begin/collect* stx) ; helper, has a boolean flag first (define-syntax (begin/collect* stx) ; helper, has a boolean flag first
(define-values (exprs always-list?) (define-values [exprs always-list?]
(let ([exprs (syntax->list stx)]) (let ([exprs (syntax->list stx)])
(if (and (pair? exprs) (pair? (cdr exprs))) (if (and (pair? exprs) (pair? (cdr exprs)))
(values (cddr exprs) (syntax-e (cadr exprs))) (values (cddr exprs) (syntax-e (cadr exprs)))
@ -178,7 +178,7 @@
(begin/text (begin/text
(include-at/relative-to/reader path-spec path-spec path-spec (include-at/relative-to/reader path-spec path-spec path-spec
(let ([xs #f]) (let ([xs #f])
(lambda (src inp) (λ (src inp)
(unless xs (unless xs
(set! xs (scribble:read-syntax-inside src inp)) (set! xs (scribble:read-syntax-inside src inp))
(when (syntax? xs) (set! xs (or (syntax->list xs) (list xs))))) (when (syntax? xs) (set! xs (or (syntax->list xs) (list xs)))))