File ld2db.dsl of Package docbook-dsssl-stylesheets

Overview Repositories Revisions Requests Users Attributes Meta

File ld2db.dsl of Package docbook-dsssl-stylesheets (Revision 4eb011aa0ac40f7e01380250904c6bdf)

Currently displaying revision 4eb011aa0ac40f7e01380250904c6bdf , Show latest

<!DOCTYPE style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN" >

;; ============================ PARAMETERS ==============================

(define %transform-element-BF% "Emphasis")
(define %transform-element-SL% "Emphasis")
(define %transform-element-TT% "Literal")
(define %ids-repl-list% `("0" "i-0" "1" "i-1" "2" "i-2" "3" "i-3"
                          "4" "i-4" "5" "i-5" "6" "i-6" "7" "i-7"
                          "8" "i-8" "9" "i-9"))

</style-specification-body>
</style-specification>

(define debug
  (external-procedure "UNREGISTERED::James Clark//Procedure::debug"))

;(declare-characteristic preserve-sdata?
;  "UNREGISTERED::James Clark//Characteristic::preserve-sdata?"
;  #f)

;; ====================== Library Functions     ========================

(define (node-list-first-element nodelist)
  ;; REFENTRY lib-node-list-first-element
  ;; PURP Return the first element node in a node list
  ;; DESC
  ;; This function returns the first node in a node list which is
  ;; an element (as opposed to a PI or anything else that might appear
  ;; in a node list).
  ;; /DESC
  ;; /REFENTRY
  (let loop ((nl nodelist))
    (if (node-list-empty? nl)
        (empty-node-list)
        (if (gi (node-list-first nl))
            (node-list-first nl)
            (loop (node-list-rest nl))))))
 
(define (ipreced nl)
  ;; REFENTRY lib-ipreced
  ;; PURP Implements ipreced as per ISO/IEC 10179:1996
  ;; DESC
  ;; Implements 'ipreced' as per ISO/IEC 10179:1996
  ;; /DESC
  ;; AUTHOR From ISO/IEC 10179:1996
  ;; /REFENTRY
  (node-list-map (lambda (snl)
                 (let loop ((prev (empty-node-list))
                            (rest (siblings snl)))
                   (cond ((node-list-empty? rest)
                          (empty-node-list))
                         ((node-list=? (node-list-first rest) snl)
                          prev)
                         (else
                          (loop (node-list-first rest)
                                (node-list-rest rest))))))
                 nl))

(define (ifollow nl)
  ;; REFENTRY
  ;; PURP Implements ifollow as per ISO/IEC 10179:1996
  ;; DESC
  ;; Implements 'ifollow' as per ISO/IEC 10179:1996
  ;; /DESC
  ;; AUTHOR From ISO/IEC 10179:1996
  ;; /REFENTRY
  (node-list-map (lambda (snl)
                   (let loop ((rest (siblings snl)))
                     (cond ((node-list-empty? rest)
                            (empty-node-list))
                           ((node-list=? (node-list-first rest) snl)
                            (node-list-first (node-list-rest rest)))
                           (else
                            (loop (node-list-rest rest))))))
                 nl))
 
(define (siblings snl)
  ;; REFENTRY
  ;; PURP Implements siblings as per ISO/IEC 10179:1996
  ;; DESC
  ;; Implements 'siblings' as per ISO/IEC 10179:1996
  ;; /DESC
  ;; AUTHOR From ISO/IEC 10179:1996
  ;; /REFENTRY
  (children (parent snl)))
 
;; ======================================================================
 
(define (sgml-root-element)
  ;; REFENTRY
  ;; PURP Returns the node that is the root element of the current document
  ;; DESC
  ;; Return the root element of the document by walking up from
  ;; wherever we are.  (Isn't this built-in to DSSSL somehow???)
  ;; /DESC
  ;; /REFENTRY
  (let loop ((root (current-node)))
    (if (node-list-empty? (parent root))
        root
        (loop (parent root)))))
 
;; ======================================================================
 
(define (repl-substring? string target pos)
  ;; REFENTRY lib-repl-substring-p
  ;; PURP Returns true if the specified substring can be replaced
  ;; DESC
  ;; Returns '#t' if 'target' occurs at 'pos' in 'string'.
  ;; /DESC
  ;; /REFENTRY
  (let* ((could-match (<= (+ pos (string-length target))
                         (string-length string)))
         (match (if could-match
                    (substring string pos (+ pos (string-length target))) "")))
    (and could-match (string=? match target))))
 
(define (repl-substring string target repl pos)
  ;; REFENTRY lib-repl-substring
  ;; PURP Replace substring in a string
  ;; DESC
  ;; Replaces 'target' with 'repl' in 'string' at 'pos'.
  ;; /DESC
  ;; /REFENTRY
  (let ((matches (repl-substring? string target pos)))
    (if matches
        (string-append
         (substring string 0 pos)
         repl
         (substring string
                    (+ pos (string-length target))
                    (string-length string)))
        string)))
 
(define (repl-substring-list? string replace-list pos)
  ;; REFENTRY lib-repl-substring-list-p
  ;; PURP Perform repl-substring? with a list of target/replacement pairs
  ;; DESC
  ;; Returns '#t' if any target in 'replace-list' occurs at 'pos' in 'string'.
  ;; ARGS
  ;; ARG 'string'
  ;; The string in which replacement should be tested.
  ;; /ARG
  ;; ARG 'replace-list'
  ;; A list of target/replacement pairs.  This list is just a list of
  ;; strings, treated as pairs.  For example, '("was" "x" "is" "y")'.
  ;; In this example, 'was' may be replaced by 'x' and 'is' may be
  ;; replaced by 'y'.
  ;; /ARG
  ;; ARG 'pos'
  ;; The location within 'string' where the test will occur.
  ;; /ARG
  ;; /ARGS
  ;; /DESC
  ;; EXAMPLE
  ;; '(repl-substring-list? "this is it" ("was" "x" "is" "y") 2)'
  ;; returns '#t': "is" could be replaced by "y".
  ;; /EXAMPLE
  ;; /REFENTRY
  (let loop ((list replace-list))
    (let ((target (car list))
          (repl   (car (cdr list)))
          (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
          #t
          (if (null? rest)
              #f
              (loop rest))))))
 
(define (repl-substring-list-target string replace-list pos)
  ;; REFENTRY lib-repl-substring-list-target
  ;; PURP Return the target that matches in a string
  ;; DESC
  ;; Returns the target in 'replace-list' that matches in 'string' at 'pos'
  ;; See also 'repl-substring-list?'.
  ;; /DESC
  ;; /REFENTRY
  (let loop ((list replace-list))
    (let ((target (car list))
          (repl   (car (cdr list)))
          (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
          target
          (if (null? rest)
              #f
              (loop rest))))))
 
(define (repl-substring-list-repl string replace-list pos)
  ;; REFENTRY lib-repl-substring-list-repl
  ;; PURP Return the replacement that would be used in the string
  ;; DESC
  ;; Returns the replacement in 'replace-list' that would be used for the
  ;; target that matches in 'string' at 'pos'
  ;; See also 'repl-substring-list?'.
  ;; /DESC
  ;; /REFENTRY
  (let loop ((list replace-list))
    (let ((target (car list))
          (repl   (car (cdr list)))
          (rest   (cdr (cdr list))))
      (if (repl-substring? string target pos)
          repl
          (if (null? rest)
              #f
              (loop rest))))))
 
(define (repl-substring-list string replace-list pos)
  ;; REFENTRY lib-repl-substring-list
  ;; PURP Replace the first target in the replacement list that matches
  ;; DESC
  ;; Replaces the first target in 'replace-list' that matches in 'string'
  ;; at 'pos' with its replacement.
  ;; See also 'repl-substring-list?'.
  ;; /DESC
  ;; /REFENTRY
  (if (repl-substring-list? string replace-list pos)
      (let ((target (repl-substring-list-target string replace-list pos))
            (repl   (repl-substring-list-repl string replace-list pos)))
        (repl-substring string target repl pos))
      string))
 
(define (string-replace string target repl)
  ;; REFENTRY lib-string-replace
  ;; PURP Replace all occurances of a target substring in a string
  ;; DESC
  ;; Replaces all occurances of 'target' in 'string' with 'repl'.
  ;; /DESC
  ;; /REFENTRY
  (let loop ((str string) (pos 0))
    (if (>= pos (string-length str))
        str
        (loop (repl-substring str target repl pos)
              (if (repl-substring? str target pos)
                  (+ (string-length repl) pos)
                  (+ 1 pos))))))
 
(define (node-list-first-element-after-match nodelist match-el)
  ;; REFENTRY lib-node-list-first-element
  ;; PURP Return the first element node in a node list after given element
  ;; DESC
  ;; This function returns the first node in a node list which appears
  ;; after the given match element n element (as opposed to a PI or
  ;; aanything else that might appear n a node list).
  ;; /DESC
  ;; /REFENTRY
  (let loop ((nl nodelist))
    (if (node-list-empty? nl)
        (empty-node-list)
        (if (equal? (gi (node-list-first nl)) match-el)
            (let loop-2 ((nl (node-list-rest nl)))
              (if (node-list-empty? nl)
                  (empty-node-list)
                  (if (gi (node-list-first nl))
                      (node-list-first nl)
                      (loop-2 (node-list-rest nl)))))
            (loop (node-list-rest nl))))))

</style-specification-body>
</style-specification>

;; ============================ TOP LEVEL ==============================

(declare-flow-object-class formatting-instruction
  "UNREGISTERED::James Clark//Flow Object Class::formatting-instruction")
(declare-flow-object-class element
  "UNREGISTERED::James Clark//Flow Object Class::element")
(declare-flow-object-class empty-element
  "UNREGISTERED::James Clark//Flow Object Class::empty-element")
(declare-flow-object-class document-type
  "UNREGISTERED::James Clark//Flow Object Class::document-type")
(declare-flow-object-class processing-instruction
  "UNREGISTERED::James Clark//Flow Object Class::processing-instruction")
(declare-flow-object-class entity
  "UNREGISTERED::James Clark//Flow Object Class::entity")
(declare-flow-object-class entity-ref
  "UNREGISTERED::James Clark//Flow Object Class::entity-ref")

(declare-characteristic preserve-sdata?
  "UNREGISTERED::James Clark//Characteristic::preserve-sdata?" #t)

(define (start-tag str)
  (string-append "<" str ">" ))

(define (end-tag str)
  (string-append "</" str ">"))

(define (comment-tag str)
  (string-append "<" "--" str "--" ">"))

; newline
;(define %RE% "\U-000D")
(define %RE% "&#RE;")

(define (write-string str)
  (make formatting-instruction
        data: str))

(define (write-string-RE str)
  (make formatting-instruction
        data: (string-append str %RE%)))

(define (RE-write-string str)
  (make formatting-instruction
        data: (string-append %RE% str)))

(define (RE-write-string-RE str)
  (make formatting-instruction
        data: (string-append %RE% str %RE%)))

; procedure for enclosing inline data between pre and aft text
(define ($make-inline$ pre aft)
  (sosofo-append
    (write-string pre)
    (process-children)
    (write-string aft)))

; procedure for enclosing a block of data between pre and aft text
; Note: always terminates with a newline
(define ($make-block$ pre aft)
  (sosofo-append
    (write-string pre)
    (process-children)
    (write-string-RE aft)))

(define ($remap-attr$ el)
  (cons (list "REMAP" el) `()))

(define (attr-name lis)
  (car (car lis)))

(define (attr-value lis)
  (car (cdr (car lis))))

; given a list of attribute pairs, output them
(define ($out-attributes$ attlist)
  (let loop ((rest attlist))
    (if (equal? rest `())
        (write-string ">")
        (make sequence
          (write-string (string-append " " 
                                       (attr-name rest) 
                                       "=\"" 			; open quote
                                       (attr-value rest)
                                       "\""))			; close quote
          (loop (cdr rest))))))

(define (make-block-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (RE-write-string (string-append "<" gi-nd))
      (if attributes
          ($out-attributes$ attributes)
          (write-string-RE ">"))
      sosofo
      (RE-write-string-RE (end-tag gi-nd)))))

(define (make-comment-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (RE-write-string (string-append "<" "!--" gi-nd "--" ">"))
      (if attributes
          ($out-attributes$ attributes)
          (write-string-RE ">"))
      sosofo
      (RE-write-string-RE (string-append "<" "!--" "/" gi-nd "--" ">")))))

(define (make-inline-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (write-string (string-append "<" gi-nd))
      (if attributes
          ($out-attributes$ attributes)
          (write-string ">"))
      sosofo
      (write-string (end-tag gi-nd)))))

(define (make-empty-inline-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (write-string (string-append "<" gi-nd))
      (if attributes
          ($out-attributes$ attributes)
          (write-string ">"))
      sosofo)))

(define (make-line-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (RE-write-string (string-append "<" gi-nd))
      (if attributes
          ($out-attributes$ attributes)
          (write-string ">"))
      sosofo
      (write-string-RE (end-tag gi-nd)))))

(define (make-empty-line-element #!optional #!key gind attributes
                            (sosofo (process-children)))
  (let ((gi-nd (if gind gind (gi (current-node)))))
    (sosofo-append
      (RE-write-string (string-append "<" gi-nd))
      (if attributes
          ($out-attributes$ attributes)
          (write-string ">"))
      sosofo)))

</style-specification-body>
</style-specification>

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; From the DSSSL Cookbook
;; http://www.mulberrytech.com/dsssl/dsssldoc/cookbook/cookbook.html
;; Default rule

(default (output-element))

(define (output-element #!optional (node (current-node)))
  (if (node-property "must-omit-end-tag?" node)
      (make empty-element
            attributes: (copy-attributes))
      (make element
            attributes: (copy-attributes))))

(define (copy-attributes #!optional (nd (current-node)))
  (let loop ((atts (named-node-list-names (attributes nd))))
    (if (null? atts)
        '()
        (let* ((name (car atts))
               (value (attribute-string name nd)))
          (if value
              (cons (list name value)
                    (loop (cdr atts)))
              (loop (cdr atts)))))))

(element LINUXDOC (process-children))

(element ARTICLE 
  (make sequence
    (make document-type name: "Article"
                        public-id: "-//Davenport//DTD DocBook V3.0//EN")
    (make-block-element gind: "Article")))

(element BOOK
  (make sequence
    (make document-type name: "Book" 
                        public-id: "-//Davenport//DTD DocBook V3.0//EN" )
    (make-block-element gind: "Book")))

(element REPORT
  (make sequence
    (make document-type name: "Book" 
                        public-id: "-//Davenport//DTD DocBook V3.0//EN" )
    (make-block-element gind: "Book" attributes: `(("remap" "report")))))

(element TITLEPAG
  (if (equal? (gi (parent (current-node))) "ARTICLE")
      (make-block-element gind: "ArtHeader")
      (make-block-element
        gind: "BookInfo"
        sosofo: (make-block-element
                  gind: "BookBiblio"))))

(element DATE (make-line-element gind: "PubDate"))

; this may need to be fixed-up manually
(element NAME
  (let ((htmlurl-nl (select-elements (children (current-node)) "HTMLURL")))
    (make sequence
      (make-line-element gind: "FirstName")
      (if (node-list-empty? htmlurl-nl)
          (empty-sosofo)
          (make-block-element gind: "AuthorBlurb"
            sosofo: (make-line-element gind: "Para"
                      sosofo: (with-mode name-htmlurl
                                (process-node-list htmlurl-nl))))))))

;; does'nt work well, correct by hand
;(element INST (make element gi: "OrgName"))
(element INST (empty-sosofo))

(element ABSTRACT
  (make-block-element
    gind: "Abstract"
    sosofo: (make-block-element gind: "Para")))

;; Norm's stylesheets build this stuff
(element TOC (empty-sosofo))
(element LOT (empty-sosofo))
(element LOF (empty-sosofo))

(element TITLE (make-line-element gind: "Title"))

;; ========================== BLOCK ELEMENTS ============================

(element P
  (let ((para-empty (if (and (equal? 0 (string-length (data (current-node))))
                             (node-list-empty? (children (current-node))))
                        #t #f)))
    (if para-empty
        (empty-sosofo)		; don't leave empty paragraphs lying around!
        (make-block-element gind: "Para" ))))

(element APPENDIX
  (let* ((follow-nd (ifollow (current-node)))
         (chapt-next (if (equal? (gi follow-nd) "CHAPT") #t #f)))
    (if chapt-next
        (empty-sosofo)
        (make-empty-line-element
          sosofo: (make-line-element
                    gind: "Title"
                    sosofo: (literal "Appendix"))))))

(element CHAPT
  (let* ((preced-nd (ipreced (current-node)))
         (apdx-prev (if (equal? (gi preced-nd) "APPENDIX") #t #f)))
    (if apdx-prev
        ($make-sect$ "Appendix")
        ($make-sect$ "Chapter"))))

(element SECT ($make-sect$ "Sect1"))
(element SECT1 ($make-sect$ "Sect2"))
(element SECT2 ($make-sect$ "Sect3"))
(element SECT3 ($make-sect$ "Sect4"))
(element SECT4 ($make-sect$ "Sect5"))

;; build a section (or chapter)
(define ($make-sect$ gi-name)
  (let ((attrs ($get-sect-id$ (current-node))))
    (make-block-element gind: gi-name attributes: attrs)))

;; look for a label element in a heading element then put the 'id' in
;; the section (or chapter) attribute
(define ($get-sect-id$ nd)
  (let* ((heading (node-list-first
                    (select-elements (children nd) "HEADING")))
         (label (select-elements (children heading) "LABEL"))
         (label-id (if (node-list-empty? label)
                       #f
                       ($fix-ids$ 
                         (attribute-string "id" (node-list-first label)))))
         (attrs (if label-id
                    (cons (list "id" ($fix-ids$ label-id)) (copy-attributes))
                    (copy-attributes))))
    attrs))

;; look for a label element in a child elements
(define ($get-child-id$ nd)
  (let* ((label (select-elements (children nd) "LABEL")))
    (if (node-list-empty? label)
        #f
        ($fix-ids$ (attribute-string "id" (node-list-first label))))))

(element HEADING (make-line-element gind: "Title" ))

(element HEADER (empty-sosofo))
(element LHEAD (empty-sosofo))
(element RHEAD (empty-sosofo))

;; ============================== LISTS =================================

(element ITEM
  (let ((para-nl (select-elements (children (current-node)) "P"))
        (item-empty (if (equal? 0 (string-length (data (current-node))))
                        #t #f)))
    (make sequence
      (write-string-RE (start-tag "ListItem"))
      (if (node-list-empty? para-nl)
          (make-block-element gind: "Para")
          (if item-empty
              (process-children)
              (make sequence
                (write-string-RE (start-tag "Para"))
                (process-children))))
      (write-string-RE (end-tag "ListItem")))))

(element ENUM (make-block-element gind: "OrderedList" ))
(element ITEMIZE (make-block-element gind: "ItemizedList" ))

(element DESCRIP 
  (make sequence
    (write-string-RE (start-tag "VariableList"))
    (process-children)
    (write-string-RE (end-tag "VarListEntry"))
    (write-string (end-tag "VariableList"))))

(element TAG 
  (let ((END-ENTRY (cond ((> (child-number) 1)
                          (end-tag "VarListEntry"))
                          (else ""))))
  (make sequence
    (write-string END-ENTRY)
    (RE-write-string (start-tag "VarListEntry"))
    (make-line-element gind: "Term")
    (write-string (start-tag "ListItem")))))

;; =========================== FONT CHANGES =============================

(element EM
  (if (equal? (gi (parent)) "TT")
      (process-children)
      (make-inline-element gind: "Emphasis")))

(element TT
  (make-inline-element gind: %transform-element-TT%
                       attributes: `(("remap" "tt"))))

(element BF
  (if (equal? (gi (parent)) "TT")
      (process-children)
      (make-inline-element gind: %transform-element-BF%
                           attributes: `(("remap" "bf")))))

(element IT
  (if (equal? (gi (parent)) "TT")
      (process-children)
      (make-inline-element gind: "Emphasis"
                           attributes: `(("remap" "it")))))

(element SL
  (make-inline-element gind: %transform-element-SL%
                       attributes: `(("remap" "sl"))))

(element CODE (make-block-element gind: "ProgramListing"))

(element TSCREEN (make-block-element gind: "Screen"))
(element VERB (process-children))

;============================  Linking ==================================

;; ID and IDREF cannot begin with a number and cannot have embedded spaces
;; or under bars.
(define ($fix-ids$ string)
  (let* ((nw-str (string-replace string " " "-"))
         (ub-str (string-replace nw-str "_" "-")))
    (repl-substring-list ub-str %ids-repl-list% 0)))

(element REF
  (make-empty-inline-element 
        gind: "XRef"
        attributes: `(("LinkEnd" ,($fix-ids$ (attribute-string "id"))))))

(element HTMLURL
  (if (equal? (gi (parent (current-node))) "NAME")
    (empty-sosofo)
    (make element gi: "ULink"
          attributes: `(("URL" ,(attribute-string "URL")))
          (if (attribute-string "NAME")
              (literal (attribute-string "NAME"))
              (literal (attribute-string "URL")) ))))
 
(element URL
    (make element gi: "ULink"
          attributes: `(("URL" ,(attribute-string "URL")))
          (if (attribute-string "NAME")
              (literal (attribute-string "NAME"))
              (literal (attribute-string "URL")) )))
              ; FIXME: Name attribute
 
(element LABEL
  (if (equal? (gi (parent (current-node))) "P")
      (make-empty-inline-element
        gind: "Anchor"
        attributes: `(("id" ,($fix-ids$ (attribute-string "id")))))
      (empty-sosofo)))

;; for when htmlurl is a child of name
(mode name-htmlurl
  (element HTMLURL
    (make-block-element
      gind: "ULink"
      attributes: `(("URL" ,(attribute-string "URL")))
      sosofo: (if (attribute-string "NAME")
                  (literal (attribute-string "NAME"))
                  (literal (attribute-string "URL")) ))))

;; ======================== FIGURES and TABLES ==========================

(define (make-graphic-el fileref)
  (make-line-element gind: "Graphic" attributes: `(("FileRef" ,fileref))))

(element FIGURE
  (let* ((caption-nl (select-elements (descendants (current-node)) "CAPTION"))
         (label-id ($get-child-id$ caption-nl))
         (eps (select-elements (children (current-node)) "EPS"))
         (file (attribute-string "file" (node-list-first eps))))
     (make-block-element
       gind: "Figure"
       attributes: (if label-id `(("id" ,($fix-ids$ label-id))) `())
       sosofo: (if (not (node-list-empty? caption-nl))
                   (make sequence
                     (with-mode caption-to-title
                       (process-node-list caption-nl))
                     (make-graphic-el (if file file "dummy")))
                   (make-graphic-el (if file file "dummy"))))))

(element EPS (empty-sosofo))
(element PH (empty-sosofo))

(element CAPTION (empty-sosofo))

(mode caption-to-title
  (element CAPTION
      (make-line-element gind: "Title")))

;; currently the frame attribute must be set manually
(element TABLE
  (let* ((caption-nl (select-elements (descendants (current-node)) "CAPTION"))
         (label-id ($get-child-id$ caption-nl)))
    (if (node-list-empty? caption-nl)
        (make-block-element gind: "InformalTable")
        (make-block-element gind: "Table" 
                            attributes: (if label-id
                                            `(("id" ,($fix-ids$ label-id)))
                                            `())
                            sosofo: (make sequence
                                      (with-mode caption-to-title
                                        (process-node-list caption-nl))
                                      (process-children))))))

(define ($count-cols$ ca-str)
   (let loop ((cnt 0) (str ca-str))
     (if (equal? (string-length str) 0)
         cnt
         (if (equal? (substring str 0 1) "|")
             (loop cnt (substring str 1 (string-length str)))
             (loop (+ 1 cnt) (substring str 1 (string-length str)))))))

(define ($make-colspecs$ ca-str)
  (if (equal? (string-length ca-str) 0)
      (empty-sosofo)
      (if (equal? (substring ca-str 0 1) "|")
          ($make-colspecs$ (substring ca-str 1 (string-length ca-str)))
          (let loop ((str ca-str))
            (if (equal? (string-length str) 0)
                (empty-sosofo)
                (let* ((col-sep (if (> (string-length str) 1)
                                    (if (equal? (substring str 1 2) "|")
                                        #t
                                        #f)
                                    #f))
                       (pos (if col-sep 2 1)))
                  (make sequence
                    ($build-colspec$ (substring str 0 1) col-sep)
                    (loop (substring str pos (string-length str))))))))))

(define ($build-colspec$ cell-align col-sep)
  (let* ((cellalign (case cell-align
                          (("l") "Left")
                          (("c") "Center")
                          (("r") "Right")
                          (else  "Left")))
         (attrs (cons (list "Align" cellalign) (cons
           (if col-sep
               (list "Colsep" "1")
               (list "Colsep" "0"))
           `()))))
    (make-empty-line-element
      gind: "ColSpec"
      attributes: attrs
      sosofo: (empty-sosofo))))

(element TABULAR
  (let* ((col-attr (attribute-string "CA"))
         (colcnt ($count-cols$ col-attr)))
    (make-block-element
      gind: "TGroup"
      attributes: `(("Cols" ,(number->string colcnt)))
      sosofo: (make sequence
                ($make-colspecs$ col-attr)
                (RE-write-string-RE (start-tag "TBody"))
                (row-check-border (node-list-first (children (current-node))))
                (write-string    (start-tag "Entry"))
                (process-children)
                (write-string-RE (end-tag "Entry"))
                (write-string-RE (end-tag "Row"))
                (write-string-RE (end-tag "TBody"))))))

(element COLSEP
  (make sequence
    (write-string (end-tag "Entry"))
    (RE-write-string (start-tag "Entry"))))

;; find the next "rowsep" then check if a "hline" immediatly follows
(define (row-check-border nd)
  (let* ((follow-nl (follow nd))
         (af-nl (node-list-first-element-after-match follow-nl "ROWSEP"))
         (hline-next (if (equal? (gi af-nl) "HLINE") #t #f)))
      (if hline-next
          (make sequence
            (write-string (string-append "<" "Row"))
            (if attributes
                (make sequence
                  ($out-attributes$ `(("RowSep" "1")))
                  (write-string %RE%))
                (write-string-RE ">")))
          (write-string-RE (start-tag "Row")))))

(element ROWSEP
    (make sequence
      (write-string-RE (end-tag "Entry"))
      (write-string-RE (end-tag "Row"))
      (row-check-border (current-node))
      (write-string-RE (start-tag "Entry"))))

; for now
(element HLINE (empty-sosofo))

; don't do any math
(element DM (empty-sosofo))

(element FOOTNOTE
  (make-block-element
    sosofo: (make-block-element gind: "Para")))

(element NEWLINE
  (write-string %RE%))

</style-specification-body>
</style-specification>
</style-sheet>

Places

File ld2db.dsl of Package docbook-dsssl-stylesheets (Revision 4eb011aa0ac40f7e01380250904c6bdf)

Places