~aasg/haunted-blog

dc7248ceeb87a1305eac8f59a720b15abc6540da — Aluísio Augusto Silva Gonçalves 1 year, 2 months ago 9619879
haunt: Add TOC generation
3 files changed, 106 insertions(+), 2 deletions(-)

M haunt.scm
A scm/aasg/outline.scm
A scm/aasg/sxml/toc.scm
M haunt.scm => haunt.scm +14 -2
@@ 6,6 6,7 @@
(add-to-load-path (string-append (dirname (current-filename)) "/scm"))
(use-modules (aasg sxml from-pandoc)
             (aasg sxml reparse-extended-markdown)
             (aasg sxml toc)
             (haunt asset)
             (haunt builder blog)
             (haunt builder atom)


@@ 96,7 97,6 @@
      (meta (@ (name "viewport")
               (content "width=device-width, initial-scale=1")))
      (title ,(string-append title " — " (site-title site)))
      (base (@ (href ".")))
      (link (@ (rel "alternate")
               (title "Posts")
               (type "application/atom+xml")


@@ 229,6 229,18 @@
      (lambda (filename)
        (values (read-yaml-preamble filename) (pandoc-md->sxml filename))))))

; Wrap a Haunt reader so that its output includes a table of contents.
(define (with-toc reader)
  (define (add-toc sxml) (cons (sxml-toc sxml) sxml))
  (define (read-and-add-toc reader filename)
    (let-values (((metadata sxml) (reader filename)))
      (if (assq-ref metadata 'toc)
          (values metadata (add-toc sxml))
          (values metadata sxml))))
  (let ((matcher (reader-matcher reader))
        (reader (reader-proc reader)))
    (make-reader matcher (cute read-and-add-toc reader <>))))

(define (uncollected-pages directory theme)
  (lambda (site posts)
    (let ((post->page (lambda (post)


@@ 258,7 270,7 @@
      '((author . "Aluísio Augusto Silva Gonçalves")
        (author-profile . "https://aasg.name"))
      #:file-filter (lambda (filename) (not (aasg-file-fragment? filename)))
      #:readers (list extended-markdown-reader)
      #:readers (map with-toc (list pandoc-reader))
      #:builders (list (blog #:theme aasg-post-theme
                             #:collections `(("Home" "index.html" ,posts/reverse-chronological)))
                       (uncollected-pages "pages" aasg-page-theme)

A scm/aasg/outline.scm => scm/aasg/outline.scm +23 -0
@@ 0,0 1,23 @@
(define-module (aasg outline)
               #:use-module (srfi srfi-1)
               #:use-module (srfi srfi-11)
               #:export (rank-outline))

(define (collect-next-nodes rank-of current-level rest siblings children)
  (if (or (null? rest) (< (rank-of (car rest)) current-level))
      (values rest siblings children)
      (let-values (((r s c) (recurse-outline rank-of rest current-level)))
	(collect-next-nodes rank-of current-level r (append siblings s) (append children c)))))

(define (recurse-outline rank-of lst previous-level)
  (if (null? lst)
      (values '() '() '())
      (let*-values (((node rest) (car+cdr lst))
		    ((rest siblings children) (collect-next-nodes rank-of (rank-of node) rest '() '())))
	(let ((node-outline (cons* (cons node children) siblings)))
	  (if (eqv? (rank-of node) previous-level)
	      (values rest node-outline '())
	      (values rest '() node-outline))))))

(define (rank-outline rank-of lst)
    (let-values (((r s c) (recurse-outline rank-of lst 0))) c))

A scm/aasg/sxml/toc.scm => scm/aasg/sxml/toc.scm +69 -0
@@ 0,0 1,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
       (summary "Table of contents")
       (ul ,@(map toc-entry outline)))))