bkyk8rc3zvpnsf5inmcqq4n3k98cv6hj-my-site-hyper-literate-git.test.suzanne.soy-0.0.1

commit e7d056b02dc82efdaa15625d9411be5bbb8f67f5
parent a45e38adfcdbf44adca30b25372d89d729ba8464
Author: Matthew Flatt <mflatt@racket-lang.org>
Date:   Tue, 27 May 2008 17:02:24 +0000

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

svn: r9980

original commit: af9d53e7f046a0336b739699d652da5eda553422

Diffstat:
M
collects/scribble/html-render.ss
 | 
25
+++++++++++++++----------
M
collects/scribble/latex-render.ss
 | 
6
+++++-
M
collects/scribble/struct.ss
 | 
33
+++++++++++++++++++++++++++++++++

3 files changed, 53 insertions(+), 11 deletions(-)
diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss
@@ -752,7 +752,7 @@
         [else (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)
                         (with-attributes-style raw-style)
                         raw-style)]
@@ -760,7 +760,12 @@
                         (if (with-attributes? raw-style)
                             (map (lambda (p) (list (car p) (cdr p)))
                                  (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
          [(symbol? style)
           (case style
@@ -804,15 +809,18 @@
                   ,@(super render-element e part ri)))]
          [(target-url? style)
           (if (current-no-links)
-              (super render-element e part ri)
+              (super-render/attribs)
               (parameterize ([current-no-links #t])
                 `((a ([href ,(let ([addr (target-url-addr style)])
                                (if (path? addr)
                                    (from-root addr (get-dest-directory))
                                    addr))]
-                      ,@(if (string? (target-url-style style))
-                            `([class ,(target-url-style style)])
-                            null)
+                      ;; The target-url chains to another style. Allow
+                      ;;  `with-attributes' inside as well as outside:
+                      ,@(let ([style (target-url-style style)])
+                          (if (string? style)
+                              `([class ,style])
+                              null))
                       . ,(attribs))
                      ,@(super render-element e part ri)))))]
          [(url-anchor? style)
@@ -842,10 +850,7 @@
                                 p))]
                     . ,(attribs))
                    ,@sz)))]
-         [else 
-          (if (with-attributes? raw-style)
-              `((span ,(attribs) ,@(super render-element e part ri)))
-              (super render-element e part ri))])))
+         [else (super-render/attribs)])))
 
     (define/override (render-table t part ri need-inline?)
       (define t-style (table-style t))
diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss
@@ -128,7 +128,11 @@
                               ri)
               (printf " ``"))
             (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?)
                           (printf "{\\~a{" s)
                           (parameterize ([rendering-tt (or tt?
diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss
@@ -490,3 +490,36 @@
  [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-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)