html/dbindex.dsl

   1 ;; $Id: dbindex.dsl,v 1.5 2003/01/15 08:24:13 adicarlo Exp $
   2 ;;
   3 ;; This file is part of the Modular DocBook Stylesheet distribution.
   4 ;; See ../README or http://docbook.sourceforge.net/projects/dsssl/
   5 ;;
   6
   7 ;; ................... INDEX TERMS (EMBEDDED MARKERS) ...................
   8
   9 (element indexterm
  10   (if html-index
  11       (let* ((id (if (attribute-string (normalize "id"))
  12                      (attribute-string (normalize "id"))
  13                      (generate-anchor))))
  14         (make element gi: "A"
  15               attributes: (list (list "NAME" id))
  16               (empty-sosofo)))
  17       (empty-sosofo)))
  18
  19 (element primary (empty-sosofo))
  20 (element secondary (empty-sosofo))
  21 (element tertiary (empty-sosofo))
  22 (element see (empty-sosofo))
  23 (element seealso (empty-sosofo))
  24
  25 ;; =========================== INDEX ELEMENTS ===========================
  26
  27 (element (setindex title) (empty-sosofo))
  28 (element setindex
  29   (let ((preamble (node-list-filter-by-not-gi
  30                    (children (current-node))
  31                    (list (normalize "indexentry"))))
  32         (entries  (node-list-filter-by-gi
  33                    (children (current-node))
  34                    (list (normalize "indexentry")))))
  35     (html-document
  36      (with-mode head-title-mode
  37        (literal (element-title-string (current-node))))
  38      (make element gi: "DIV"
  39            attributes: (list (list "CLASS" (gi)))
  40            ($component-separator$)
  41            ($component-title$)
  42            (process-node-list preamble)
  43            (if (node-list-empty? entries)
  44                (empty-sosofo)
  45                (make element gi: "DL"
  46                      (process-node-list entries)))))))
  47
  48 (element (index title) (empty-sosofo))
  49 (element index
  50   (let ((preamble (node-list-filter-by-not-gi
  51                    (children (current-node))
  52                    (list (normalize "indexentry"))))
  53         (entries  (node-list-filter-by-gi
  54                    (children (current-node))
  55                    (list (normalize "indexentry")))))
  56     (html-document
  57      (with-mode head-title-mode
  58        (literal (element-title-string (current-node))))
  59      (make element gi: "DIV"
  60            attributes: (list (list "CLASS" (gi)))
  61            ($component-separator$)
  62            ($component-title$)
  63            (process-node-list preamble)
  64            (if (node-list-empty? entries)
  65                (empty-sosofo)
  66                (make element gi: "DL"
  67                      (process-node-list entries)))))))
  68
  69
  70 (element (indexdiv title) (empty-sosofo))
  71 (element indexdiv
  72   (let ((preamble (node-list-filter-by-not-gi
  73                    (children (current-node))
  74                    (list (normalize "indexentry"))))
  75         (entries  (node-list-filter-by-gi
  76                    (children (current-node))
  77                    (list (normalize "indexentry")))))
  78     (html-document
  79      (with-mode head-title-mode
  80        (literal (element-title-string (current-node))))
  81      (make element gi: "DIV"
  82            attributes: (list (list "CLASS" (gi)))
  83            ($section-separator$)
  84            ($section-title$)
  85            (process-node-list preamble)
  86            (if (node-list-empty? entries)
  87                (empty-sosofo)
  88                (make element gi: "DL"
  89                      (process-node-list entries)))))))
  90
  91 (define (break-node-list nodes breakatgi)
  92   ;; Given a _node_ list "PRIM SEC TERT SEC SEC TERT PRIM SEC PRIM PRIM"
  93   ;; and the breakatgi of "PRIM", returns the _list_ of _node_ lists:
  94   ;; '("PRIM SEC TERT SEC SEC TERT" "PRIM SEC" "PRIM" "PRIM")
  95   (let loop ((nl nodes) (result '()) (curlist (empty-node-list)))
  96     (if (node-list-empty? nl)
  97         (if (node-list-empty? curlist)
  98             result
  99             (append result (list curlist)))
 100         (if (equal? (gi (node-list-first nl)) breakatgi)
 101             (loop (node-list-rest nl)
 102                   (if (node-list-empty? curlist)
 103                       result
 104                       (append result (list curlist)))
 105                   (node-list-first nl))
 106             (loop (node-list-rest nl)
 107                   result
 108                   (node-list curlist (node-list-first nl)))))))
 109
 110 (define (process-primary primnode secnl)
 111   (let ((see?     (equal? (gi (node-list-first secnl))
 112                           (normalize "seeie")))
 113         (seealso? (equal? (gi (node-list-first secnl))
 114                           (normalize "seealsoie")))
 115         (second   (break-node-list secnl (normalize "secondaryie"))))
 116     (if (or see? seealso?)
 117         (process-terminal primnode secnl #t)
 118         (make sequence
 119           (process-nonterminal primnode)
 120           (if (node-list-empty? secnl)
 121               (empty-sosofo)
 122               (make element gi: "DD"
 123                     (make element gi: "DL"
 124                           (let sloop ((secs second))
 125                             (if (null? secs)
 126                                 (empty-sosofo)
 127                                 (make sequence
 128                                   (let* ((nodes (car secs))
 129                                          (sec   (node-list-first nodes))
 130                                          (terts (node-list-rest nodes)))
 131                                     (process-secondary sec terts))
 132                                   (sloop (cdr secs))))))))))))
 133
 134 (define (process-secondary secnode tertnl)
 135   (let ((see?     (equal? (gi (node-list-first tertnl))
 136                           (normalize "seeie")))
 137         (seealso? (equal? (gi (node-list-first tertnl))
 138                           (normalize "seealsoie")))
 139         (tert (break-node-list tertnl (normalize "tertiaryie"))))
 140     (if (or see? seealso?)
 141         (process-terminal secnode tertnl)
 142         (make sequence
 143           (process-nonterminal secnode)
 144           (make element gi: "DD"
 145                 (make element gi: "DL"
 146                       (let tloop ((terts tert))
 147                         (if (null? terts)
 148                             (empty-sosofo)
 149                             (make sequence
 150                               (let* ((nodes (car terts))
 151                                      (tert  (node-list-first nodes))
 152                                      (sees  (node-list-rest nodes)))
 153                                 (process-tertiary tert sees))
 154                               (tloop (cdr terts)))))))))))
 155
 156 (define (process-tertiary tertnode seenl)
 157   (process-terminal tertnode seenl))
 158
 159 (define (process-terminal node seenl #!optional (output-id #f))
 160   (let ((id (attribute-string (normalize "id") (parent node))))
 161     (make sequence
 162       (make element gi: "DT"
 163             (if id
 164                 (make element gi: "A"
 165                       attributes: (list (list "NAME" id))
 166                       (empty-sosofo))
 167                 (empty-sosofo))
 168             (process-node-list node))
 169       (if (node-list-empty? seenl)
 170           (empty-sosofo)
 171           (make element gi: "DD"
 172                 (make element gi: "DL"
 173                       (let loop ((nl seenl))
 174                         (if (node-list-empty? nl)
 175                             (empty-sosofo)
 176                             (make sequence
 177                               (make element gi: "DT"
 178                                     (process-node-list
 179                                      (node-list-first nl)))
 180                               (loop (node-list-rest nl)))))))))))
 181
 182 (define (process-nonterminal node)
 183   (make element gi: "DT"
 184         (process-node-list node)))
 185
 186 (element indexentry
 187   (let* ((primary   (break-node-list (children (current-node))
 188                                      (normalize "primaryie"))))
 189     (make sequence
 190       (let ploop ((prims primary))
 191         (if (null? prims)
 192             (empty-sosofo)
 193             (make sequence
 194               (let* ((nodes (car prims))
 195                      (prim  (node-list-first nodes))
 196                      (secs  (node-list-rest nodes)))
 197                 (process-primary prim secs))
 198               (ploop (cdr prims))))))))
 199
 200 (element primaryie (process-children))
 201 (element secondaryie (process-children))
 202 (element tertiaryie (process-children))
 203
 204 (define (indexentry-link nd)
 205   (let* ((preferred (not (node-list-empty?
 206                           (select-elements (children (current-node))
 207                                            (normalize "emphasis"))))))
 208     (make element gi: "A"
 209           attributes: (list (list "HREF"
 210                                   (attribute-string (normalize "url"))))
 211           (process-children))))
 212
 213 (element (primaryie ulink)
 214   (indexentry-link (current-node)))
 215
 216 (element (secondaryie ulink)
 217   (indexentry-link (current-node)))
 218
 219 (element (tertiaryie ulink)
 220   (indexentry-link (current-node)))
 221
 222 (element seeie
 223   (let ((linkend (attribute-string (normalize "linkend"))))
 224       (if linkend
 225           (make element gi: "A"
 226                 attributes: (list (list "HREF"
 227                                         (href-to (element-with-id linkend))))
 228                 (literal (gentext-element-name (current-node)))
 229                 (literal (gentext-label-title-sep (current-node)))
 230                 (process-children))
 231           (make sequence
 232             (literal (gentext-element-name (current-node)))
 233             (literal (gentext-label-title-sep (current-node)))
 234             (process-children)))))
 235
 236 (element seealsoie
 237   (let* ((alinkends (attribute-string (normalize "linkends")))
 238          (linkends  (if alinkends
 239                         (split alinkends)
 240                         '()))
 241          (linkend   (if alinkends
 242                         (car linkends)
 243                         #f)))
 244     (if linkend
 245         (make element gi: "A"
 246               attributes: (list (list "HREF"
 247                                       (href-to (element-with-id linkend))))
 248               (literal (gentext-element-name (current-node)))
 249               (literal (gentext-label-title-sep (current-node)))
 250               (process-children))
 251         (make sequence
 252           (literal (gentext-element-name (current-node)))
 253           (literal (gentext-label-title-sep (current-node)))
 254           (process-children)))))
 255
 256 ;; =====================HTML INDEX PROCESSING ==============================
 257
 258 (define (htmlnewline)
 259   (make formatting-instruction data: "&#13;"))
 260
 261 (define (htmlindexattr attr)
 262   (if (attribute-string (normalize attr))
 263       (make sequence
 264         (make formatting-instruction data: attr)
 265         (make formatting-instruction data: " ")
 266         (make formatting-instruction data: (attribute-string
 267                                             (normalize attr)))
 268         (htmlnewline))
 269       (empty-sosofo)))
 270
 271 (define (htmlindexterm)
 272   (let* ((attr    (gi (current-node)))
 273          (content (data (current-node)))
 274          (string  (string-replace content "&#13;" " "))
 275          (sortas  (attribute-string (normalize "sortas"))))
 276     (make sequence
 277       (make formatting-instruction data: attr)
 278       (if sortas
 279           (make sequence
 280             (make formatting-instruction data: "[")
 281             (make formatting-instruction data: sortas)
 282             (make formatting-instruction data: "]"))
 283           (empty-sosofo))
 284       (make formatting-instruction data: " ")
 285       (make formatting-instruction data: string)
 286       (htmlnewline))))
 287
 288 (define (htmlindexzone zone)
 289   (let loop ((idlist (split zone)))
 290     (if (null? idlist)
 291         (empty-sosofo)
 292         (make sequence
 293           (htmlindexzone1 (car idlist))
 294           (loop (cdr idlist))))))
 295
 296 (define (htmlindexzone1 id)
 297   (let* ((target (ancestor-member (element-with-id id)
 298                                   (append (book-element-list)
 299                                           (division-element-list)
 300                                           (component-element-list)
 301                                           (section-element-list))))
 302          (title  (string-replace (element-title-string target) "&#13;" " ")))
 303     (make sequence
 304       (make formatting-instruction data: "ZONE ")
 305       (make formatting-instruction data: (href-to target))
 306       (htmlnewline)
 307
 308       (make formatting-instruction data: "TITLE ")
 309       (make formatting-instruction data: title)
 310       (htmlnewline))))
 311
 312 (mode htmlindex
 313   ;; this mode is really just a hack to get at the root element
 314   (root (process-children))
 315
 316   (default
 317     (if (node-list=? (current-node) (sgml-root-element))
 318         (make entity
 319           system-id: (html-entity-file html-index-filename)
 320           (process-node-list (select-elements
 321                               (descendants (current-node))
 322                               (normalize "indexterm"))))
 323         (empty-sosofo)))
 324
 325   (element indexterm
 326     (let* ((target (ancestor-member (current-node)
 327                                     (append (book-element-list)
 328                                             (division-element-list)
 329                                             (component-element-list)
 330                                             (section-element-list))))
 331            (title  (string-replace (element-title-string target) "&#13;" " ")))
 332       (make sequence
 333         (make formatting-instruction data: "INDEXTERM ")
 334         (make formatting-instruction data: (href-to target))
 335         (htmlnewline)
 336
 337         (make formatting-instruction data: "INDEXPOINT ")
 338         (make formatting-instruction data: (href-to (current-node)))
 339         (htmlnewline)
 340
 341         (make formatting-instruction data: "TITLE ")
 342         (make formatting-instruction data: title)
 343         (htmlnewline)
 344
 345         (htmlindexattr "scope")
 346         (htmlindexattr "significance")
 347         (htmlindexattr "class")
 348         (htmlindexattr "id")
 349         (htmlindexattr "startref")
 350
 351         (if (attribute-string (normalize "zone"))
 352             (htmlindexzone (attribute-string (normalize "zone")))
 353             (empty-sosofo))
 354
 355         (process-children)
 356
 357         (make formatting-instruction data: "/INDEXTERM")
 358         (htmlnewline))))
 359
 360   (element primary
 361     (htmlindexterm))
 362
 363   (element secondary
 364     (htmlindexterm))
 365
 366   (element tertiary
 367     (htmlindexterm))
 368
 369   (element see
 370     (htmlindexterm))
 371
 372   (element seealso
 373     (htmlindexterm))
 374 )