ドキュメント

オープンオフィス(以下OOo) をやめて、RacketのScribbleに乗り換え中。
乗換えと言っても、Racketに付属しているものをそのまま使うのではなく、ドキュメント生成スクリプトも同時に書いている。なので、コンセプトだけを使うといった感じ。
Chibi Schemeに触発された感はあるが。

その際にあんまりうまいこと解決方法が見つからなかったのが以下のセクションを拾って目次に変換する処理。
用件としては、以下のようになっているリストをulとliで作成されたsxmlに変換すること。

((section
  (@ (tag "tag1") (number "1"))
  "Section 1")
 (subsection 
  (@ (tag "tag1.1") (number "1.1"))
  "Subsection 1.1")
 (subsection 
  (@ (tag "tag1.2") (number "1.2"))
  "Subsection 1.2")
 (section
  (@ (tag "tag2") (number "2"))
  "Section 2")
 (subsection 
  (@ (tag "tag2.1") (number "2.1"))
  "Subsection 2.1")
 (subsubsection 
  (@ (tag "tag2.1.1") (number "2.1.1"))
  "Subsection 2.1.1")
 (sub*section 
  (@ (tag "tag2.1.1.1") (number "2.1.1.1"))
  "Subsection 2.1.1.1")
 (section
  (@ (tag "tag3") (number "3"))
  "Section 3"))

期待される出力

(div (@ (id "G137") (class "table-of-contents"))
     (ul (@ (class "section"))
  (li (@ (class "section"))
      (a (@ (href "#tag1"))
  (span (@ (class "section-number")) "1")
  "Section 1")
      (ul (@ (class "sub-section"))
   (li (@ (class "sub-section"))
       (a (@ (href "#tag1.1"))
   (span (@ (class "section-number")) "1.1")
   "Section 1.1"))
   (li (@ (class "sub-section"))
       (a (@ (href "#tag1.2"))
   (span (@ (class "section-number")) "1.2")
   "Section 1.2"))))
  (li (@ (class "section"))
      (a (@ (href "#tag2"))
  (span (@ (class "section-number")) "2")
  "Section 2")
      (ul (@ (class "sub-section"))
   (li (@ (class "sub-section"))
       (a (@ (href "#tag2.1"))
   (span (@ (class "section-number")) "2.1")
   "Section 2.1")
       (ul (@ (class "sub-sub-section"))
    (li (@ (class "sub-sub-section"))
        (a (@ (href "#tag2.1.1"))
    (span (@ (class "section-number"))
          "2.1.1")
    "Section 2.1.1")
        (ul (@ (class "sub-sub-sub-section"))
     (li (@ (class "sub-sub-sub-section"))
         (a (@ (href "#tag2.1.1.1"))
     (span (@ (class "section-number"))
           "2.1.1.1")
     "Section 2.1.1.1"))))))))
  (li (@ (class "section"))
      (a (@ (href "#tag3"))
  (span (@ (class "section-number")) "3")
  "Section 3"))))

単にulとliで構成されたリストにちょっとしたhtmlのメタ情報が入ったものといった感じ。これが結構てこずった。
最終的にはこんな風になったけど、もうちょっといい感じにならないだろうか？

;; sxml toolsをふんだんに使ってます。
(define *section-classes*
  '((section       . "section")
    (subsection    . "sub-section")
    (subsubsection . "sub-sub-section")
    (sub*section   . "sub-sub-sub-section")))

(define (content-list-handler element)
  (define (process contents)
    (define (li-gen content class)
      (let* ((attrs (sxml:attr-list-node content))
      (tag   (cond ((assq 'tag attrs) => cadr)))
      (section (cond ((assq 'number attrs) => cadr)
       (else
        (assertion-violation 'li-gen
        "section is not defined" content)))))
 `((li (@ (class ,class))
       (a (@ (href ,(format "#~a" tag)))
   (span (@ (class "section-number")) ,section)
   ,@(map phase2/dispath (sxml:content content)))))))
    (define (ul-gen class)
      `(ul (@ (class ,class))))
    (define (rec contents generator top)
      (let loop ((contents contents)
   (r top))
 (if (null? contents)
     r
     (let ((content (car contents)))
       (let-values (((class depth) (generator content)))
  (let loop ((i 0)
      (r r))
    (if (= i depth)
        (cond ((and (zero? i) ;; top
      (eq? (car r) 'ul))
        (append! r (li-gen content class)))
       (else
        (let ((tail (car (list-tail r (- (length r) 1)))))
          (cond ((eq? (car tail) 'ul)
          (append! tail (li-gen content class))
          r)
         (else
          (let ((ul (ul-gen class)))
     (append! ul (li-gen content class))
     (if (eq? (car tail) 'li)
         (append! tail (list ul))
         (append! r (list ul)))
     r))))))
        (loop (+ i 1)
       (let((rr (car (list-tail r (- (length r) 1)))))
         (if (eq? (car rr) 'li)
      rr
      (car (list-tail rr (- (length rr) 1))))))))
  (loop (cdr contents) r))))))

    (define (section-generator element)
      (define len (length *section-classes*))
      (define sections (map car *section-classes*))
      (cond ((assq (car element) *section-classes*)
      => (lambda (slot)
    (let ((name (car slot))
   (class (cdr slot)))
      (values class (- len (length (memq name sections)))))))
     (else
      (assertion-violation 'section-generator
      "unknown tag" element))))
    ;; assume first one is section
    (rec contents section-generator (ul-gen "section")))

  (let* ((contents (*table-of-contents*))
  (attr (sxml:attr-list-node element))
  (id   (cond ((and attr (assq 'id attr)) => cadr)
       (else (symbol->string (gensym))))))
    `(div (@ (id ,id)
      (class "table-of-contents"))
   ,(process contents))
    )
  )

リストの作成を破壊的に行っているので、なんとなく反則技を使っている気分。いい点は、*section-classes*に追加のサブセクションを足せば簡単にネストできることか。4つ以上サブセクションが要るドキュメントなんて読みたくないが・・・