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

schemeblock improvements and reference-manual work

Browse Source 
svn: r6468

original commit: d2f0b1756ccdd2ac01fde3b731d9de17d913af82
This commit is contained in:
Matthew Flatt 2007-06-04 06:34:16 +00:00
parent b2601a6b8b
commit 8d828c0cb9
3 changed files with 103 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/scribble/html-render.ss
View File

@ -175,7 +175,10 @@
[(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))] [(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))]
[(subscript) `((sub ,@(super render-element e part ht)))] [(subscript) `((sub ,@(super render-element e part ht)))]
[(superscript) `((sup ,@(super render-element e part ht)))] [(superscript) `((sup ,@(super render-element e part ht)))]
[(hspace) `((tt ,@(map (lambda (c) 'nbsp) (string->list (content->string (element-content e))))))] [(hspace) `((tt ,@(let ([str (content->string (element-content e))])
(if (= 1 (string-length str))
'(" ")
(map (lambda (c) 'nbsp) (string->list str))))))]
[else (error 'html-render "unrecognized style symbol: ~e" style)])] [else (error 'html-render "unrecognized style symbol: ~e" style)])]
[(string? style) [(string? style)
`((span ([class ,style]) ,@(super render-element e part ht)))] `((span ([class ,style]) ,@(super render-element e part ht)))]
@ -195,15 +198,22 @@
[(at-left) '((align "left"))] [(at-left) '((align "left"))]
[else null])) [else null]))
,@(map (lambda (flows) ,@(map (lambda (flows)
`(tr ,@(map (lambda (d a) `(tr ,@(map (lambda (d a va)
`(td ,@(case a `(td (,@(case a
[(#f) null] [(#f) null]
[(right) '(((align "right")))] [(right) '((align "right"))]
[(left) '(((align "left")))]) [(left) '((align "left"))])
,@(case va
[(#f) null]
[(top) '((valign "top"))]
[(bottom) '((valign "bottom"))]))
,@(render-flow d part ht))) ,@(render-flow d part ht)))
flows flows
(cdr (or (and (list? (table-style t)) (cdr (or (and (list? (table-style t))
(assoc 'alignment (or (table-style t) null))) (assoc 'alignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) flows))))
(cdr (or (and (list? (table-style t))
(assoc 'valignment (or (table-style t) null)))
(cons #f (map (lambda (x) #f) flows))))))) (cons #f (map (lambda (x) #f) flows)))))))
(table-flowss t))))) (table-flowss t)))))

118
collects/scribble/scheme.ss
View File

@ -34,7 +34,8 @@
quote quasiquote unquote unquote-splicing quote quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing syntax quasisyntax unsyntax unsyntax-splicing
for/fold for/list for*/list for for/and for/or for* for*/or for*/and for*/fold for/fold for/list for*/list for for/and for/or for* for*/or for*/and for*/fold
for-values for*/list-values for/first for/last))) for-values for*/list-values for/first for/last
set!)))
(define current-variable-list (define current-variable-list
(make-parameter null)) (make-parameter null))
@ -50,45 +51,57 @@
[init-col (or (syntax-column first) 0)] [init-col (or (syntax-column first) 0)]
[src-col init-col] [src-col init-col]
[dest-col 0] [dest-col 0]
[highlight? #f]
[col-map (make-hash-table 'equal)] [col-map (make-hash-table 'equal)]
[next-col-map (make-hash-table 'equal)]
[line (or (syntax-line first) 0)]) [line (or (syntax-line first) 0)])
(define (finish-line!) (define (finish-line!)
(when multi-line? (when multi-line?
(set! docs (cons (make-flow (list (make-paragraph (reverse content)))) (set! docs (cons (make-flow (list (make-paragraph (reverse content))))
docs)) docs))
(set! content null))) (set! content null)))
(define (out v cls) (define out
(unless (equal? v "") (case-lambda
(if (equal? v "\n") [(v cls)
(if multi-line? (out v cls (if (string? v) (string-length v) 1))]
(begin [(v cls len)
(finish-line!) (unless (equal? v "")
(out prefix cls)) (if (equal? v "\n")
(out " " cls)) (if multi-line?
(begin (begin
(set! content (cons (if color? (finish-line!)
(make-element cls (list v)) (out prefix cls))
(make-element 'tt (list v))) (out " " cls))
content)) (begin
(set! dest-col (+ dest-col (if (string? v) (string-length v) 1))))))) (set! content (cons ((if highlight?
(lambda (c)
(make-element "highlighted" (list c)))
values)
(if color?
(make-element cls (list v))
(make-element 'tt (list v))))
content))
(set! dest-col (+ dest-col len)))))]))
(define advance (define advance
(case-lambda (case-lambda
[(c init-line! delta) [(c init-line! delta)
(let ([c (+ delta (syntax-column c))] (let ([c (+ delta (syntax-column c))]
[l (syntax-line c)] [l (syntax-line c)])
[span (syntax-span c)]) (let ([new-line? (and l (l . > . line))])
(when (and l (l . > . line)) (when new-line?
(out "\n" no-color) (out "\n" no-color)
(set! line l) (set! line l)
(init-line!)) (set! col-map next-col-map)
(when c (set! next-col-map (make-hash-table 'equal))
(let ([d-col (hash-table-get col-map src-col src-col)]) (init-line!))
(let ([amt (+ (- c src-col) (- d-col dest-col))]) (let ([d-col (hash-table-get col-map c (+ dest-col (- c src-col)))])
(let ([amt (- d-col dest-col)])
(when (positive? amt) (when (positive? amt)
(let ([old-dest-col dest-col]) (let ([old-dest-col dest-col])
(out (make-element 'hspace (list (make-string amt #\space))) #f) (out (make-element 'hspace (list (make-string amt #\space))) #f)
(set! dest-col (+ old-dest-col amt)))))) (set! dest-col (+ old-dest-col amt))))))
(set! src-col (+ c (or span 1)))))] (set! src-col c)
(hash-table-put! next-col-map src-col dest-col)))]
[(c init-line!) (advance c init-line! 0)])) [(c init-line!) (advance c init-line! 0)]))
(define (convert-infix c quote-depth) (define (convert-infix c quote-depth)
(let ([l (syntax->list c)]) (let ([l (syntax->list c)])
@ -167,21 +180,36 @@
l))] l))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:line)) (eq? (syntax-e (car (syntax-e c))) 'code:line))
(for-each (loop init-line! quote-depth) (let ([l (cdr (syntax->list c))])
(cdr (syntax->list c)))] (for-each (loop init-line! quote-depth)
l))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:hilite))
(let ([l (syntax->list c)]
[h? highlight?])
(unless (and l (= 2 (length l)))
(error "bad code:redex: ~e" (syntax-object->datum c)))
(advance c init-line!)
(set! src-col (syntax-column (cadr l)))
(hash-table-put! next-col-map src-col dest-col)
(set! highlight? #t)
((loop init-line! quote-depth) (cadr l))
(set! highlight? h?)
(set! src-col (add1 src-col)))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:quote)) (eq? (syntax-e (car (syntax-e c))) 'code:quote))
(advance c init-line!) (advance c init-line!)
(out "(" (if (positive? quote-depth) value-color paren-color)) (out "(" (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
((loop init-line! quote-depth) ((loop init-line! quote-depth)
(datum->syntax-object #'here 'quote (car (syntax-e c)))) (datum->syntax-object #'here 'quote (car (syntax-e c))))
(for-each (loop init-line! (add1 quote-depth)) (for-each (loop init-line! (add1 quote-depth))
(cdr (syntax->list c))) (cdr (syntax->list c)))
(out ")" (if (positive? quote-depth) value-color paren-color)) (out ")" (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col)] #;
(hash-table-put! next-col-map src-col dest-col)]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(memq (syntax-e (car (syntax-e c))) (memq (syntax-e (car (syntax-e c)))
'(quote quasiquote unquote unquote-splicing '(quote quasiquote unquote unquote-splicing
@ -200,13 +228,14 @@
meta-color)) meta-color))
(let ([i (cadr (syntax->list c))]) (let ([i (cadr (syntax->list c))])
(set! src-col (or (syntax-column i) src-col)) (set! src-col (or (syntax-column i) src-col))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
((loop init-line! (+ quote-depth quote-delta)) i)))] ((loop init-line! (+ quote-depth quote-delta)) i)))]
[(and (pair? (syntax-e c)) [(and (pair? (syntax-e c))
(convert-infix c quote-depth)) (convert-infix c quote-depth))
=> (lambda (converted) => (lambda (converted)
((loop init-line! quote-depth) converted))] ((loop init-line! quote-depth) converted))]
[(or (pair? (syntax-e c)) [(or (pair? (syntax-e c))
(null? (syntax-e c))
(vector? (syntax-e c))) (vector? (syntax-e c)))
(let* ([sh (or (syntax-property c 'paren-shape) (let* ([sh (or (syntax-property c 'paren-shape)
#\()] #\()]
@ -220,14 +249,20 @@
paren-color))]) paren-color))])
(advance c init-line!) (advance c init-line!)
(when (vector? (syntax-e c)) (when (vector? (syntax-e c))
(out (format "#~a" (vector-length (syntax-e c))) p-color)) (let ([vec (syntax-e c)])
(out (format "#~a" (vector-length vec)) p-color)
(if (zero? (vector-length vec))
(set! src-col (+ src-col (- (syntax-span c) 2)))
(set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
(syntax-column c)
1))))))
(out (case sh (out (case sh
[(#\[ #\?) "["] [(#\[ #\?) "["]
[(#\{) "{"] [(#\{) "{"]
[else "("]) [else "("])
p-color) p-color)
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
(let lloop ([l (if (vector? (syntax-e c)) (let lloop ([l (if (vector? (syntax-e c))
(vector->short-list (syntax-e c) syntax-e) (vector->short-list (syntax-e c) syntax-e)
c)]) c)])
@ -246,7 +281,7 @@
(advance l init-line! -2) (advance l init-line! -2)
(out ". " (if (positive? quote-depth) value-color paren-color)) (out ". " (if (positive? quote-depth) value-color paren-color))
(set! src-col (+ src-col 3)) (set! src-col (+ src-col 3))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
((loop init-line! quote-depth) l)])) ((loop init-line! quote-depth) l)]))
(out (case sh (out (case sh
[(#\[ #\?) "]"] [(#\[ #\?) "]"]
@ -254,12 +289,13 @@
[else ")"]) [else ")"])
p-color) p-color)
(set! src-col (+ src-col 1)) (set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col))] #;
(hash-table-put! next-col-map src-col dest-col))]
[(box? (syntax-e c)) [(box? (syntax-e c))
(advance c init-line!) (advance c init-line!)
(out "#&" value-color) (out "#&" value-color)
(set! src-col (+ src-col 2)) (set! src-col (+ src-col 2))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
((loop init-line! +inf.0) (unbox (syntax-e c)))] ((loop init-line! +inf.0) (unbox (syntax-e c)))]
[(hash-table? (syntax-e c)) [(hash-table? (syntax-e c))
(advance c init-line!) (advance c init-line!)
@ -269,7 +305,7 @@
"#hasheq") "#hasheq")
value-color) value-color)
(set! src-col (+ src-col 5 (if equal-table? 2 0))) (set! src-col (+ src-col 5 (if equal-table? 2 0)))
(hash-table-put! col-map src-col dest-col) (hash-table-put! next-col-map src-col dest-col)
((loop init-line! +inf.0) ((loop init-line! +inf.0)
(syntax-ize (hash-table-map (syntax-e c) cons) (syntax-ize (hash-table-map (syntax-e c) cons)
(syntax-column c))))] (syntax-column c))))]
@ -323,10 +359,14 @@
variable-color] variable-color]
[it? variable-color] [it? variable-color]
[else symbol-color])] [else symbol-color])]
[else paren-color]))) [else paren-color])
(hash-table-put! col-map src-col dest-col))]))) (string-length s)))
(hash-table-put! col-map src-col dest-col) (set! src-col (+ src-col (or (syntax-span c) 1)))
#;
(hash-table-put! next-col-map src-col dest-col))])))
(out prefix1 #f) (out prefix1 #f)
(set! dest-col 0)
(hash-table-put! next-col-map init-col dest-col)
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c) ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c)
(unless (null? content) (unless (null? content)
(finish-line!)) (finish-line!))

8
collects/scribble/scribble.css
View File

@ -144,11 +144,19 @@
} }
*/ */
.ghost {
color: white;
}
.scheme em { .scheme em {
color: black; color: black;
font-family: serif; font-family: serif;
} }
.highlighted {
background-color: #ddddff;
}
.schemeinput { .schemeinput {
color: brown; color: brown;
background-color: #eeeeee; background-color: #eeeeee;