suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

fix rendering of nested with-attributes and target-url styles

Browse Source 
svn: r9980

original commit: af9d53e7f046a0336b739699d652da5eda553422
This commit is contained in:
Matthew Flatt 2008-05-27 17:02:24 +00:00
parent a45e38adfc
commit e7d056b02d
3 changed files with 53 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -752,7 +752,7 @@
[else (render-plain-element e part ri)])) [else (render-plain-element e part ri)]))
(define/private (render-plain-element e part ri) (define/private (render-plain-element e part ri)
(let* ([raw-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)]
@ -760,7 +760,12 @@
(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
(lambda ()
(if (with-attributes? raw-style)
`((span ,(attribs) ,@(super render-element e part ri)))
(super render-element e part ri)))])
(cond (cond
[(symbol? style) [(symbol? style)
(case style (case style
@ -804,15 +809,18 @@
,@(super render-element e part ri)))] ,@(super render-element e part ri)))]
[(target-url? style) [(target-url? style)
(if (current-no-links) (if (current-no-links)
(super render-element e part ri) (super-render/attribs)
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t])
`((a ([href ,(let ([addr (target-url-addr style)]) `((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))]
,@(if (string? (target-url-style style)) ;; The target-url chains to another style. Allow
`([class ,(target-url-style style)]) ;; `with-attributes' inside as well as outside:
null) ,@(let ([style (target-url-style style)])
(if (string? style)
`([class ,style])
null))
. ,(attribs)) . ,(attribs))
,@(super render-element e part ri)))))] ,@(super render-element e part ri)))))]
[(url-anchor? style) [(url-anchor? style)
@ -842,10 +850,7 @@
p))] p))]
. ,(attribs)) . ,(attribs))
,@sz)))] ,@sz)))]
[else [else (super-render/attribs)])))
(if (with-attributes? raw-style)
`((span ,(attribs) ,@(super render-element e part ri)))
(super render-element e part ri))])))
(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))

6
collects/scribble/latex-render.ss
View File

@ -128,7 +128,11 @@
ri) ri)
(printf " ``")) (printf " ``"))
(let ([style (and (element? e) (let ([style (and (element? e)
(element-style e))] (let ([s (flatten-style
(element-style e))])
(if (with-attributes? s)
(with-attributes-style s)
s)))]
[wrap (lambda (e s tt?) [wrap (lambda (e s tt?)
(printf "{\\~a{" s) (printf "{\\~a{" s)
(parameterize ([rendering-tt (or tt? (parameterize ([rendering-tt (or tt?

33
collects/scribble/struct.ss
View File

@ -490,3 +490,36 @@
[resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)]) [resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)])
;; ----------------------------------------
(define (flatten-style s)
(cond
[(with-attributes? s)
(let ([rest (flatten-style (with-attributes-style s))])
(if (with-attributes? rest)
;; collapse nested with-attributes
(make-with-attributes
(with-attributes-style rest)
(append (with-attributes-assoc s)
(with-attributes-assoc rest)))
;; rebuild with flattened inner:
(make-with-attributes
rest
(with-attributes-assoc s))))]
[(target-url? s)
(let ([rest (flatten-style (target-url-style s))])
(if (with-attributes? rest)
;; lift nested attributes out:
(make-with-attributes
(make-target-url
(target-url-addr s)
(with-attributes-style rest))
(with-attributes-assoc rest))
;; rebuild with flattened inner:
(make-target-url
(target-url-addr s)
rest)))]
[else s]))
(provide flatten-style)