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

improved code some

Browse Source 
svn: r10265

original commit: cdbfcc1283f14bbdb1a8b533ebe78b23f8d37fb3
This commit is contained in:
Eli Barzilay 2008-06-15 05:56:46 +00:00
parent ac2eee61bb
commit ab1949f40e
1 changed files with 97 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -774,46 +774,53 @@
(let* ([raw-style (flatten-style (and (element? e) (element-style e)))] (let* ([raw-style (flatten-style (and (element? e) (element-style e)))]
[style (if (with-attributes? raw-style) [style (if (with-attributes? raw-style)
(with-attributes-style raw-style) (with-attributes-style raw-style)
raw-style)] raw-style)])
[attribs (lambda () (define (attribs)
(if (with-attributes? raw-style) (if (with-attributes? raw-style)
(map (lambda (p) (list (car p) (cdr p))) (map (lambda (p) (list (car p) (cdr p)))
(with-attributes-assoc raw-style)) (with-attributes-assoc raw-style))
null))] null))
[super-render/attribs (define (render* [x 'span])
(lambda () ;; x can be a tag name, or a list of attributes, or a tag followed by
(if (with-attributes? raw-style) ;; a list of attributes (internal use: no error checking!)
`((span ,(attribs) ,@(super render-element e part ri))) (let-values ([(tag attribs)
(super render-element e part ri)))]) (cond [(symbol? x) (values x (attribs))]
[(symbol? (car x))
(unless (null? (cddr x)) (error "boom"))
(values (car x) (append (cadr x) (attribs)))]
[else (values 'span (append x (attribs)))])]
[(content) (super render-element e part ri)])
(if (and (eq? 'span tag) (null? attribs))
content
`((,tag ,attribs ,@content)))))
(cond (cond
[(symbol? style) [(symbol? style)
(case style (case style
[(italic) `((i ,(attribs) ,@(super render-element e part ri)))] [(italic) (render* 'i)]
[(bold) `((b ,(attribs) ,@(super render-element e part ri)))] [(bold) (render* 'b)]
[(tt) `((span ([class "stt"] . ,(attribs)) ,@(super render-element e part ri)))] [(tt) (render* '([class "stt"]))]
[(no-break) `((span ([class "nobreak"] . ,(attribs)) [(no-break) (render* '([class "nobreak"]))]
,@(super render-element e part ri)))] [(sf) `((b ,@(render* '(font ([size "-1"] [face "Helvetica"])))))]
[(sf) `((b (font ([size "-1"] [face "Helvetica"] . ,(attribs)) [(subscript) (render* 'sub)]
,@(super render-element e part ri))))] [(superscript) (render* 'sup)]
[(subscript) `((sub ,(attribs) ,@(super render-element e part ri)))] [(hspace)
[(superscript) `((sup ,(attribs) ,@(super render-element e part ri)))] `((span ([class "hspace"] . ,(attribs))
[(hspace) `((span ([class "hspace"] . ,(attribs))
,@(let ([str (content->string (element-content e))]) ,@(let ([str (content->string (element-content e))])
(map (lambda (c) 'nbsp) (string->list str)))))] (map (lambda (c) 'nbsp) (string->list str)))))]
[(newline) `((br ,(attribs)))] [(newline) `((br ,(attribs)))]
[else (error 'html-render "unrecognized style symbol: ~e" style)])] [else (error 'html-render "unrecognized style symbol: ~e" style)])]
[(string? style) [(string? style) (render* `([class ,style]))]
`((span ([class ,style] . ,(attribs)) ,@(super render-element e part ri)))]
[(and (pair? style) (memq (car style) '(color bg-color))) [(and (pair? style) (memq (car style) '(color bg-color)))
(unless (and (list? style) (unless (and (list? style)
(or (and (= 4 (length style)) (case (length style)
(andmap byte? (cdr style))) [(4) (andmap byte? (cdr style))]
(and (= 2 (length style)) [(2) (member (cadr style)
(member (cadr style)
'("white" "black" "red" "green" "blue" '("white" "black" "red" "green" "blue"
"cyan" "magenta" "yellow"))))) "cyan" "magenta" "yellow"))]
[else #f]))
(error 'render-font "bad color style: ~e" style)) (error 'render-font "bad color style: ~e" style))
`((font ([style (render* `(font
([style
,(format "~acolor: ~a" ,(format "~acolor: ~a"
(if (eq? (car style) 'bg-color) "background-" "") (if (eq? (car style) 'bg-color) "background-" "")
(if (= 2 (length style)) (if (= 2 (length style))
@ -823,14 +830,12 @@
(map (lambda (v) (map (lambda (v)
(let ([s (number->string v 16)]) (let ([s (number->string v 16)])
(if (< v 16) (string-append "0" s) s))) (if (< v 16) (string-append "0" s) s)))
(cdr style)))))] (cdr style)))))])))]
. ,(attribs))
,@(super render-element e part ri)))]
[(target-url? style) [(target-url? style)
(if (current-no-links) (if (current-no-links)
(super-render/attribs) (render*)
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t])
`((a ([href ,(let ([addr (target-url-addr style)]) (render* `(a ([href ,(let ([addr (target-url-addr style)])
(if (path? addr) (if (path? addr)
(from-root addr (get-dest-directory)) (from-root addr (get-dest-directory))
addr))] addr))]
@ -839,12 +844,9 @@
,@(let ([style (target-url-style style)]) ,@(let ([style (target-url-style style)])
(if (string? style) (if (string? style)
`([class ,style]) `([class ,style])
null)) null)))))))]
. ,(attribs))
,@(super render-element e part ri)))))]
[(url-anchor? style) [(url-anchor? style)
`((a ([name ,(url-anchor-name style)] . ,(attribs)) (render* `(a ([name ,(url-anchor-name style)])))]
,@(super render-element e part ri)))]
[(image-file? style) [(image-file? style)
(let* ([src (main-collects-relative->path (image-file-path style))] (let* ([src (main-collects-relative->path (image-file-path style))]
[scale (image-file-scale style)] [scale (image-file-scale style)]
@ -869,7 +871,7 @@
p))] p))]
. ,(attribs)) . ,(attribs))
,@sz)))] ,@sz)))]
[else (super-render/attribs)]))) [else (render*)])))
(define/override (render-table t part ri need-inline?) (define/override (render-table t part ri need-inline?)
(define t-style (table-style t)) (define t-style (table-style t))