1 ;;; Copyright © 2019 Amin Bandali <bandali@gnu.org>
3 ;;; This program is free software; you can redistribute it and/or
4 ;;; modify it under the terms of the GNU General Public License as
5 ;;; published by the Free Software Foundation; either version 3 of the
6 ;;; License, or (at your option) any later version.
8 ;;; This program is distributed in the hope that it will be useful,
9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;; General Public License for more details.
13 ;;; You should have received a copy of the GNU General Public License
14 ;;; along with this program. If not, see
15 ;;; <http://www.gnu.org/licenses/>.
17 (define-module (bandali tags)
18 #:use-module (bandali prefs) ; my-*
19 #:use-module (bandali theme) ; bandali-theme
20 #:use-module (bandali utils) ; aa
21 #:use-module (haunt builder blog) ; theme-collection-template
22 #:use-module (haunt html) ; sxml->html
23 #:use-module (haunt page) ; make-page
24 #:use-module (haunt post)
25 #:use-module (ice-9 match) ; match-lambda
30 (define* (tag-uri prefix tag #:optional (ext ".html"))
31 "Return a URI relative to the site's root for a page listing entries
32 in PREFIX that are tagged with TAG."
33 (string-append "/" prefix "/" tag ext))
35 (define* (tag-pages #:key
38 (filter posts/reverse-chronological))
39 "Return a builder procedure that renders a list page for every tag
40 used in a post. All arguments are optional:
42 PREFIX: The directory in which to write the posts
43 FILTER: The procedure called to manipulate the posts list before rendering"
45 (define (tag-list tag posts all-posts)
46 (define (render-list title posts prefix)
47 (let ((body ((theme-collection-template theme)
48 site title posts prefix all-posts tag)))
49 ((theme-layout theme) site title body)))
50 (make-page (tag-uri my-tag-prefix tag)
51 (render-list (string-append "Notes tagged ‘" tag "’")
55 (let ((tag-groups (posts/group-by-tag posts)))
57 ((tag . tagged-posts) (tag-list tag tagged-posts posts)))
60 (define (tag-links posts)
61 "Generate an alphabetically sorted list of links to tagged posts.
62 The link text consists of the tag name and the number of tagged posts
64 `(ul (@ (class "tag-list"))
68 ,(aa (string-append tag
70 (number->string (length posts))
72 (tag-uri my-tag-prefix tag)))))
74 (sort (posts/group-by-tag posts)
75 (lambda (a b) (string<? (car a) (car b)))))))