add missing license files (GPLv3+)

[~bandali/bndl.org] / bandali / tags.scm

;;; Copyright © 2019 Amin Bandali <bandali@gnu.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (bandali tags)
  #:use-module (bandali prefs)          ; my-*
  #:use-module (bandali theme)          ; bandali-theme
  #:use-module (bandali utils)          ; aa
  #:use-module (haunt builder blog)     ; theme-collection-template
  #:use-module (haunt html)             ; sxml->html
  #:use-module (haunt page)             ; make-page
  #:use-module (haunt post)
  #:use-module (ice-9 match)            ; match-lambda
  #:export (tag-uri
            tag-pages
            tag-links))

(define* (tag-uri prefix tag #:optional (ext ".html"))
  "Return a URI relative to the site's root for a page listing entries
in PREFIX that are tagged with TAG."
  (string-append "/" prefix "/" tag ext))

(define* (tag-pages #:key
                    (theme bandali-theme)
                    (prefix "")
                    (filter posts/reverse-chronological))
  "Return a builder procedure that renders a list page for every tag
used in a post.  All arguments are optional:

PREFIX: The directory in which to write the posts
FILTER: The procedure called to manipulate the posts list before rendering"
  (lambda (site posts)
    (define (tag-list tag posts all-posts)
      (define (render-list title posts prefix)
        (let ((body ((theme-collection-template theme)
                     site title posts prefix all-posts tag)))
          ((theme-layout theme) site title body)))
      (make-page (tag-uri my-tag-prefix tag)
                 (render-list (string-append "Notes tagged ‘" tag "’")
                              (filter posts)
                              prefix)
                 sxml->html))
    (let ((tag-groups (posts/group-by-tag posts)))
      (map (match-lambda
             ((tag . tagged-posts) (tag-list tag tagged-posts posts)))
           tag-groups))))

(define (tag-links posts)
  "Generate an alphabetically sorted list of links to tagged posts.
The link text consists of the tag name and the number of tagged posts
in parentheses."
  `(ul (@ (class "tag-list"))
       ,(map (match-lambda
               ((tag . posts)
                `(li
                  ,(aa (string-append tag
                                      " ("
                                      (number->string (length posts))
                                      ")")
                       (tag-uri my-tag-prefix tag)))))
             ;; sort by tag
             (sort (posts/group-by-tag posts)
                   (lambda (a b) (string<? (car a) (car b)))))))