git.shemshak.org - ~bandali/bndl.org/blob - bandali/tags.scm

   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)))))))