srfi-table-of-contents.scm

(import (scheme base)
        (scheme char)
        (scheme cxr)
        (scheme file)
        (scheme process-context)
        (scheme write)
        (srfi 1)
        (srfi 13)
        (chibi html-parser)
        (chibi sxml))

(cond-expand (gauche (import (gauche base))))

(cond-expand ((library (srfi 175)) (import (srfi 175)))
             (else (define ascii-alphabetic? char-alphabetic?)
                   (define ascii-numeric? char-numeric?)))

(define (displayln . xs)
  (for-each display xs)
  (newline))

(define (writeln . xs)
  (for-each write xs)
  (newline))

(define (tag-body elem)
  (cond ((not (pair? (cdr elem))) '())
        ((and (pair? (cadr elem)) (eqv? '@ (caadr elem)))
         (cddr elem))
        (else (cdr elem))))

(define (heading-level tag)
  (case tag
    ((h1) 1)
    ((h2) 2)
    ((h3) 3)
    ((h4) 4)
    ((h5) 5)
    ((h6) 6)
    (else #f)))

(define (headings elem)
  (if (not (pair? elem)) '()
      (let* ((h-level (heading-level (car elem)))
             (body (tag-body elem)))
        (append (if h-level (list (cons h-level (car body))) '())
                (append-map headings body)))))

(define (headings->tree hs)
  (let deeper ((level #f) (hs hs))
    (let same-level ((acc '()) (hs hs))
      (if (null? hs) (values acc '())
          (let* ((h (car hs))
                 (l (car h)))
            (cond ((not level) (deeper l hs))
                  ((< l level) (values acc hs))
                  (else (let-values (((subtree hs) (deeper (+ l 1) (cdr hs))))
                          (same-level (append acc (list (cons (cdr h) subtree)))
                                      hs)))))))))

(define (string->slug string)
  (let ((chars (string-fold (lambda (char chars)
                              (cond ((or (ascii-alphabetic? char)
                                         (ascii-numeric? char))
                                     (cons char chars))
                                    ((or (null? chars)
                                         (char=? #\_ (car chars)))
                                     chars)
                                    (else
                                     (cons #\_ chars))))
                            '() (string-downcase string))))
    (list->string (reverse
                   (if (or (null? chars) (not (char=? #\_ (car chars))))
                       chars (cdr chars))))))

(define (write-html-toc indent items)
  (define slugs '())
  (define (gen-id title)
    (let loop ((i 1))
      (let ((slug (string-append "_" (string->slug title)
                                 (if (< i 2) "" (number->string i)))))
        (if (member slug slugs)
            (loop (+ i 1))
            (begin (set! slugs (append slugs (list slug)))
                   slug)))))
  (let display-list ((indent indent) (items items))
    (displayln indent "<ul>")
    (let ((indent (string-append indent "  ")))
      (for-each (lambda (item)
                  (let* ((title (car item))
                         (link (string-append
                                "<a href=\"#" (gen-id title) "\">"
                                title "</a>")))
                    (cond ((null? (cdr item))
                           (displayln indent "<li>" link "</li>"))
                          (else
                           (displayln indent "<li>")
                           (let ((indent (string-append indent "  ")))
                             (displayln indent link)
                             (display-list indent (cdr item)))
                           (displayln indent "</li>")))))
                items))
    (displayln indent "</ul>"))
  (newline)
  (for-each (lambda (slug)
              (display " id=\"") (display slug) (displayln "\""))
            slugs))

(define (wanted-heading? h)
  (and (<= 2 (car h) 4)
       (not (member (string-downcase (cdr h))
                    '("title" "author" "status" "abstract"
                      "table of contents" "copyright")))))

(define (handle-file html-file)
  (let* ((html (call-with-input-file html-file port->string))
         (sxml (call-with-input-string html html->sxml))
         (hdgs (filter wanted-heading? (headings sxml))))
    (write-html-toc "  " (headings->tree hdgs))))

(define (main args)
  (unless (= 1 (length args)) (error "Usage"))
  (handle-file (car args)))

(main (cdr (command-line)))