Ticket #366: unique-ids.patch

File unique-ids.patch, 7.6 KB (added by Moritz Heidkamp, 15 years ago)

  • html.scm

     
    3939      ((not (pair? r)) s)
    4040      (else (get-strings (cdr r) (get-strings (car r) s)))))))
    4141
    42 (define (html-transformation-rules content)
    43   `((
    44      (@ *preorder* . ,(lambda (tag elements) (cons tag elements)))
     42(define (html-transformation-rules _)
     43  (let* ((sections '())
     44         (make-unique-id (lambda (head-word)
     45                           (let ((id (internal-link head-word)))
     46                             (if (alist-ref id sections string=?)
     47                                 (conc id "-" (length sections))
     48                                 id)))))
     49    `(((@ *preorder* . ,(lambda (tag elements) (cons tag elements)))
    4550
    46      (Header
    47       *preorder*
    48       . ,(lambda (tag headers)
    49            (make-html-header headers)))
     51       (def
     52        ((sig . ,(lambda (tag types)
     53                   (map (lambda (spec)
     54                          `(span (@ (class ,(conc "definition " (car spec))))
     55                                 (em "[" ,(symbol->string (car spec)) "]")
     56                                 " " (tt ,@(cdr spec)) (br)))
     57                        types))))
     58        . ,(lambda (tag elems) elems))
     59     
     60       (pre
     61        . ,(lambda (tag elems)
     62             `(pre (tt . ,elems))))
    5063
    51      (toc ;; Re-scan the content for "section" tags and generate
    52       *macro*
    53       . ,(lambda (tag rest) ;; the table of contents
    54            `(div (@ (id "toc"))
    55                  ,rest
    56                  (ol ,(let find-sections ((content content))
    57                         (cond
    58                          ((not (pair? content)) '())
    59                          ((pair? (car content))
    60                           (append (find-sections (car content))
    61                                   (find-sections (cdr content))))
    62                          ((eq? (car content) 'section)
    63                           (let* ((level (cadr content))
    64                                  (head-word (caddr content))
    65                                  (href (conc "#" (internal-link head-word)))
    66                                  (subsections (find-sections (cdddr content))))
    67                             (cond ((and (integer? level) head-word)
    68                                    `((li (a (@ (href ,href)) ,head-word)
    69                                          ,@(if (null? subsections)
    70                                                '()
    71                                                `((ol ,subsections))))))
    72                                   (else
    73                                    (error 'html-transformation-rules
    74                                           "section elements must be of the form (section level head-word . contents)")))))
    75                          (else (find-sections (cdr content)))))))))
     64       (image-link
     65        *macro*
     66        . ,(lambda (tag elems)
     67             `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
     68                                                '()
     69                                                `((alt ,(cadr elems))
     70                                                  (title ,(cadr elems))))))))
    7671     
    77      (section
    78       *macro*
    79       . ,(lambda (tag elems)
    80            (let ((level (car elems))
    81                  (head-word (cadr elems))
    82                  (contents (cddr elems)))
    83              (cond ((and (integer? level) head-word)
    84                     `((,(string->symbol (string-append "h" (number->string level)))
    85                       (@ (id ,(internal-link head-word)))
    86                       ,head-word ) . ,contents))
    87                   (else
    88                    (error 'html-transformation-rules
    89                           (conc "section elements must be of the form (section level head-word . contents), got " elems))))
    90              )))
     72       (int-link
     73        *macro*
     74        . ,(lambda (tag elems)
     75             `(a (@ (href ,(car elems)) (class "internal"))
     76                 ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
     77     
     78       (link
     79        *macro*
     80        . ,(lambda (tag elems)
     81             `(a (@ (href ,(car elems)) (class "external"))
     82                 ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
    9183
    92      (section*
    93       *macro*
    94       . ,(lambda (tag elems)
    95            (let ((level (car elems))
    96                  (head-word (cadr elems))
    97                  (contents (cddr elems)))
    98              (cond ((and (integer? level) head-word)
    99                     `((,(string->symbol (string-append "h" (number->string level)))
    100                       ,head-word ) . ,contents))
    101                   (else
    102                    (error 'html-transformation-rules
    103                           (conc "section elements must be of the form (section level head-word . contents), got " elems))))
    104              )))
     84       (section
     85        *preorder/ss*
     86        . ,(lambda (tag elems ss #!optional parent)
    10587
    106      (def
    107        ((sig . ,(lambda (tag types)
    108                   (map (lambda (spec)
    109                          `(span (@ (class ,(conc "definition " (car spec))))
    110                                 (em "[" ,(symbol->string (car spec)) "]")
    111                                 " " (tt ,@(cdr spec)) (br)))
    112                        types))))
    113        . ,(lambda (tag elems) elems))
    114      
    115      (pre
    116       . ,(lambda (tag elems)
    117            `(pre (tt . ,elems))))
     88             (let* ((level (car elems))
     89                    (head-word (cadr elems))
     90                    (id (make-unique-id head-word)))
    11891
    119      (image-link
    120       *macro*
    121       . ,(lambda (tag elems)
    122            `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems))
    123                                               '()
    124                                               `((alt ,(cadr elems))
    125                                                 (title ,(cadr elems))))))))
    126      
    127      (int-link
    128       *macro*
    129       . ,(lambda (tag elems)
    130            `(a (@ (href ,(car elems)) (class "internal"))
    131                ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
    132      
    133      (link
    134       *macro*
    135       . ,(lambda (tag elems)
    136            `(a (@ (href ,(car elems)) (class "external"))
    137                ,(if (null? (cdr elems)) (car elems) (cadr elems)))))
     92               (set! sections (cons (list id parent head-word) sections))
    13893
    139      ,@alist-conv-rules*
    140      )
     94               (if (and (integer? level) head-word)
     95                   (let* ((handle-section (cdr (alist-ref 'section ss)))
     96                          (children (pre-post-order* (cddr elems)
     97                                                     (cons `(section *preorder/ss*
     98                                                                     . ,(lambda (tag elems _)
     99                                                                          (handle-section tag elems ss id)))
     100                                                           ss))))
    141101
    142     (
    143      (html:begin
    144       . ,(lambda (tag elems)
    145            (list
    146             xhtml-1.0-strict
    147             "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
    148              elems
    149              "</html>")))
     102                     `((,(string->symbol (string-append "h" (number->string level)))
     103                        (@ (id ,id)) ,head-word) . ,children))
     104                   (error 'html-transformation-rules
     105                          (conc "section elements must be of the form (section level head-word . contents), got " elems))))))
    150106
    151      (verbatim
    152       *preorder*
    153       . ,(lambda (tag elems)
    154            elems))
     107       (section*
     108        . ,(lambda (tag elems)
     109             (let ((level (car elems))
     110                   (head-word (cadr elems))
     111                   (contents (cddr elems)))
     112               (if (and (integer? level) head-word)
     113                   `((,(string->symbol (string-append "h" (number->string level)))
     114                      ,head-word) . ,contents)
     115                   (error 'html-transformation-rules
     116                          (conc "section elements must be of the form (section level head-word . contents), got " elems))))))
     117       
     118       ,@alist-conv-rules*)
    155119
    156      ,@universal-conversion-rules*)
    157     )
    158   )
     120      ((toc
     121        *macro*
     122        . ,(lambda (tag rest)
     123             `(div (@ (id "toc"))
     124                   ,rest
     125                   ,@(let ((sections (reverse sections)))
     126                       (let descend ((level (filter (lambda (s) (not (cadr s))) sections)))
     127                         (if (null? level)
     128                             '()
     129                             `((ol ,@(map (lambda (section)
     130                                            (let* ((id (car section))
     131                                                   (subsections (filter (lambda (s) (equal? id (cadr s))) sections)))
     132                                              `(li (a (@ (href ,(conc "#" id)))
     133                                                      ,(caddr section))
     134                                                   ,@(descend subsections))))
     135                                          level)))))))))
     136       
     137       (html:begin
     138        . ,(lambda (tag elems)
     139             (list
     140              xhtml-1.0-strict
     141              "<html xmlns=\"http://www.w3.org/1999/xhtml\">"
     142              elems
     143              "</html>")))
     144
     145       (verbatim
     146        *preorder*
     147        . ,(lambda (tag elems)
     148             elems))
     149
     150       ,@universal-conversion-rules*))))