~aasg/haunted-blog

ref: fef67bdcac88c14b6ac6affe93e290c1a4fb6ee2 haunted-blog/scm/aasg/sxml/toc.scm -rw-r--r-- 2.5 KiB
fef67bdc — Aluísio Augusto Silva Gonçalves Render post tags and relayout post lists 9 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
(define-module (aasg sxml toc)
               #:use-module (aasg outline)
               #:use-module (srfi srfi-1)
               #:use-module (sxml match)
               #:use-module (sxml simple)
               #:use-module (sxml transform)
               #:export (flat-outline sxml-outline sxml-toc))

; Return a list of heading elements found in the document, in pre-order.
(define (flat-outline sxml)
  (define headings '())
  (define (append-heading . sxml)
    (set! headings (cons sxml headings)))
  (pre-post-order sxml `((h1 *preorder* . ,append-heading)
                         (h2 *preorder* . ,append-heading)
                         (h3 *preorder* . ,append-heading)
                         (h4 *preorder* . ,append-heading)
                         (h5 *preorder* . ,append-heading)
                         (h6 *preorder* . ,append-heading)
                         (*default* . ,(lambda (. sxml) sxml))
                         (*text* . ,(lambda (_ text) text))))
  (reverse headings))

(define (sxml-outline sxml)
  (define (heading-level node)
    (case (car node)
      ((h1) 1)
      ((h2) 2)
      ((h3) 3)
      ((h4) 4)
      ((h5) 5)
      ((h6) 6)))
  (rank-outline heading-level (flat-outline sxml)))

(define (toc-link heading)
  (sxml-match heading
              ((h1 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))
              ((h2 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))
              ((h3 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))
              ((h4 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))
              ((h5 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))
              ((h6 (@ (id ,id)) ,text ...)
               `(a (@ (href ,(string-append "#" id))) ,text ...))))

(define (toc-entry outline)
  (define (node? e) (not (list? (car e))))
  (cond
    ((null? outline)
     '())
    ((node? outline)
      `(li ,(toc-link outline)))
    ((and (node? (car outline)) (null? (cdr outline)))
      `(li ,(toc-link (car outline))))
    ((and (node? (car outline)) (not (null? (cdr outline))))
     `(li ,(toc-link (car outline))
          (ul ,@(map toc-entry (cdr outline)))))
    (else
      (error "NO MATCH FOR " outline))))

(define (sxml-toc sxml)
  (let ((outline (sxml-outline sxml)))
    `(details (@ (role "navigation"))
              (summary "Table of contents")
              (ul ,@(map toc-entry outline)))))