| 1 | ;;; Copyright © 2019 Amin Bandali <bandali@gnu.org> |
| 2 | ;;; |
| 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. |
| 7 | ;;; |
| 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. |
| 12 | ;;; |
| 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/>. |
| 16 | |
| 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 |
| 26 | #:export (tag-uri |
| 27 | tag-pages |
| 28 | tag-links)) |
| 29 | |
| 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)) |
| 34 | |
| 35 | (define* (tag-pages #:key |
| 36 | (theme bandali-theme) |
| 37 | (prefix "") |
| 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: |
| 41 | |
| 42 | PREFIX: The directory in which to write the posts |
| 43 | FILTER: The procedure called to manipulate the posts list before rendering" |
| 44 | (lambda (site posts) |
| 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 "’") |
| 52 | (filter posts) |
| 53 | prefix) |
| 54 | sxml->html)) |
| 55 | (let ((tag-groups (posts/group-by-tag posts))) |
| 56 | (map (match-lambda |
| 57 | ((tag . tagged-posts) (tag-list tag tagged-posts posts))) |
| 58 | tag-groups)))) |
| 59 | |
| 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 |
| 63 | in parentheses." |
| 64 | `(ul (@ (class "tag-list")) |
| 65 | ,(map (match-lambda |
| 66 | ((tag . posts) |
| 67 | `(li |
| 68 | ,(aa (string-append tag |
| 69 | " (" |
| 70 | (number->string (length posts)) |
| 71 | ")") |
| 72 | (tag-uri my-tag-prefix tag))))) |
| 73 | ;; sort by tag |
| 74 | (sort (posts/group-by-tag posts) |
| 75 | (lambda (a b) (string<? (car a) (car b))))))) |