add `title' to post tags, ask people to email me directly for now

[~bandali/bndl.org] / bandali / theme.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 theme)
  #:use-module (bandali prefs)          ; my-*
  #:use-module (bandali tags)           ; tag-*
  #:use-module (bandali utils)
  #:use-module (haunt builder blog)     ; theme
  #:use-module (haunt post)             ; post-*
  #:use-module (haunt site)             ; site-*
  #:use-module (haunt utils)            ; string->date*
  #:use-module (srfi srfi-19)
  #:export (base-layout
            post-uri
            post-list-table
            bandali-theme))

(define* (base-layout site body #:key title copy license-page?)
  `((doctype "html")
    (html
     (head
      (meta (@ (charset "utf-8")))
      (meta (@ (name "viewport")
               (content "width=device-width, initial-scale=1")))
      (title ,(if title (string-append title " — " (site-title site))
                  "Amin Bandali’s Personal Site"))
      (link (@ (rel "icon")
               (href "/gnu.ico")))
      ,(stylesheet "reset")
      ,(stylesheet "style"))
     (body
      (main ,body)
      (footer
       (p "Copyright © "
          ,(if copy copy "2016–2019")
          " Amin Bandali.  See "
          ,(if license-page? "the above"
               (aa "license.html" "/license.html"))
          " for license conditions.  Please copy and share."))))))

(define* (post-uri site post #:optional prefix)
  (string-append (or prefix "") "/"
                 (site-post-slug site post) ".html"))

(define* (post-list-table site posts #:optional prefix)
  `((table
     (@ (class "post-list"))
     (tbody
      ,@(map
         (lambda (post)
           `(tr
             (td ,(aa (post-ref post 'title)
                      (post-uri site post prefix)))
             (td (small (@ (title
                            ,(date->string (post-date post)
                                           my-secondary-date-format)))
                        ,(date->string (post-date post)
                                       my-primary-date-format)))))
         posts)))))

(define (my-post-template post)
  `((header
     (h1 ,(post-ref post 'title))
     (address "By " ,(aa (post-ref post 'author) "/")
              " <" ,(post-ref post 'email) ">")
     (p (@ (class "date"))
        (span (@ (title ,(date->string (post-date post)
                                       my-secondary-date-format)))
              ,(date->string (post-date post)
                             my-primary-date-format))
        ,(if (post-ref post 'updated)
             `(" (updated on "
               (span (@ (title
                         ,(date->string (post-ref post 'updated)
                                        my-secondary-date-format)))
                     ,(date->string (post-ref post 'updated)
                                    my-primary-date-format))
               ")") '()))
     ,(if (post-ref post 'tags)
          `(p (@ (class "tags"))
              ,@(intersperse
                 (map (lambda (tag)
                        (aa tag (tag-uri my-tag-prefix tag)
                            "Notes tagged ‘" tag "’"))
                      (post-ref post 'tags))
                 ", "))
          '()))
    ,(post-sxml post)
    (p (@ (class "muted inbox"))
       "Got a question or comment?  Write to me at my email address "
       "at the top of this page!")))

(define* (my-collection-template site title posts prefix
                                 #:optional all-posts tag)
  `((h2 ,title
        ,(if tag
             (aa `(img (@ (class "feed-icon-h2")
                          (src "/icon-16px.png")
                          (alt "subscribe to atom feed")))
                 (tag-uri my-tag-prefix tag ".xml"))
             '()))
    ,(post-list-table site posts prefix)
    (h2 (@ (id "tags")) "Tags")
    ,(tag-links (or all-posts posts))
    ,(if tag
         '(a (@ (href "/notes.html"))
             "← all notes")
         '())))

(define bandali-theme
  (theme #:name "bandali"
         #:layout
         (lambda (site title body)
           (base-layout site body
                        #:title title))
         #:post-template my-post-template
         #:collection-template my-collection-template))

(module-define!
 (resolve-module '(haunt builder blog))
 'render-post
 (lambda (theme site post)
   (let ((title (post-ref post 'title))
         (body ((theme-post-template theme) post))
         (copy (post-ref post 'copyright)))
     (base-layout site body #:title title #:copy copy))))

(register-metadata-parser! 'updated string->date*)