Break up giant haunt.scm file into many modules.

1 files changed, 194 insertions, 0 deletions

diff --git a/theme.scm b/theme.scm
new file mode 100644
index 0000000..16f0c41
--- /dev/null
+++ b/theme.scm
@@ -0,0 +1,194 @@
+;;; Copyright © 2018-2021 David Thompson <davet@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 (theme)
+  #:use-module (haunt builder blog)
+  #:use-module (haunt html)
+  #:use-module (haunt page)
+  #:use-module (haunt post)
+  #:use-module (haunt site)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-19)
+  #:use-module (utils)
+  #:export (dthompson-theme
+            static-page
+            project-page))
+
+(define %cc-by-sa-link
+  '(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
+      "Creative Commons Attribution Share-Alike 4.0 International"))
+
+(define %cc-by-sa-button
+  '(a (@ (class "cc-button")
+         (href "https://creativecommons.org/licenses/by-sa/4.0/"))
+      (img (@ (src "https://licensebuttons.net/l/by-sa/4.0/80x15.png")))))
+
+(define (first-paragraph post)
+  (let loop ((sxml (post-sxml post))
+             (result '()))
+    (match sxml
+      (() (reverse result))
+      ((or (('p ...) _ ...) (paragraph _ ...))
+       (reverse (cons paragraph result)))
+      ((head . tail)
+       (loop tail (cons head result))))))
+
+(define dthompson-theme
+  (theme #:name "dthompson"
+         #:layout
+         (lambda (site title body)
+           `((doctype "html")
+             (head
+              (meta (@ (charset "utf-8")))
+              (title ,(string-append title " — " (site-title site)))
+              ,(stylesheet "reset")
+              ,(stylesheet "fonts")
+              ,(stylesheet "dthompson"))
+             (body
+              (div (@ (class "container"))
+                   (div (@ (class "nav"))
+                        (ul (li ,(link "David Thompson" "/"))
+                            (li (@ (class "fade-text")) " ")
+                            (li ,(link "About" "/about.html"))
+                            (li ,(link "Blog" "/index.html"))
+                            (li ,(link "Projects" "/projects.html"))))
+                   ,body
+                   (footer (@ (class "text-center"))
+                           (p (@ (class "copyright"))
+                              "© 2020 David Thompson"
+                              ,%cc-by-sa-button)
+                           (p "The text and images on this site are
+free culture works available under the " ,%cc-by-sa-link " license.")
+                           (p "This website is built with "
+                              (a (@ (href "https://dthompson.us/projects/haunt.html"))
+                                 "Haunt")
+                              ", a static site generator written in "
+                              (a (@ (href "https://gnu.org/software/guile"))
+                                 "Guile Scheme")
+                              "."))))))
+         #:post-template
+         (lambda (post)
+           `((h1 (@ (class "title")),(post-ref post 'title))
+             (div (@ (class "date"))
+                  ,(date->string (post-date post)
+                                 "~B ~d, ~Y"))
+             (div (@ (class "post"))
+                  ,(post-sxml post))))
+         #:collection-template
+         (lambda (site title posts prefix)
+           (define (post-uri post)
+             (string-append "/" (or prefix "")
+                            (site-post-slug site post) ".html"))
+
+           `((h1 ,title
+                 (a (@ (href "/feed.xml"))
+                    (img (@ (src "images/feed.png")))))
+             ,(map (lambda (post)
+                     (let ((uri (string-append "/"
+                                               (site-post-slug site post)
+                                               ".html")))
+                       `(div (@ (class "summary"))
+                             (h2 (a (@ (href ,uri))
+                                    ,(post-ref post 'title)))
+                             (div (@ (class "date"))
+                                  ,(date->string (post-date post)
+                                                 "~B ~d, ~Y"))
+                             (div (@ (class "post"))
+                                  ,(first-paragraph post))
+                             (a (@ (href ,uri)) "read more ➔"))))
+                   posts)))))
+
+(define (static-page title file-name body)
+  (lambda (site posts)
+    (make-page file-name
+               (with-layout dthompson-theme site title body)
+               sxml->html)))
+
+(define* (project-page #:key name file-name description usage requirements
+                       installation manual? license repo releases guix-package)
+  (define (tarball-url version)
+    (string-append "https://files.dthompson.us/"
+                   repo "/" repo "-" version
+                   ".tar.gz"))
+  (define body
+    `((h1 ,name)
+      ,description
+      ,@(if usage
+            `((h2 "Usage")
+              ,usage)
+            '())
+      ,@(if manual?
+         `((h2 "Documentation")
+           (p ,(anchor "View the reference manual"
+                       (string-append "/manuals/" repo "/index.html"))))
+         '())
+      (h2 "Releases")
+      (ul ,(map (match-lambda
+                  ((version date)
+                   (let ((url (tarball-url version)))
+                     `(li ,(date->string date "~Y-~m-~d")
+                          " — " ,version " — "
+                          ,(anchor (string-append repo "-" version ".tar.gz")
+                                   url)
+                          " — "
+                          ,(anchor "GPG signature"
+                                   (string-append url ".asc"))))))
+                releases))
+      (h2 "Requirements")
+      (ul ,(map (lambda (requirement)
+                  `(li ,requirement))
+                requirements))
+      (h2 "Installation")
+      ,@(if installation
+            (list installation)
+            (match (car releases)
+              ((version _)
+               `(,@(if guix-package
+                       `((p "To install " ,name " with the GNU Guix package manager, run:")
+                         (pre "guix install " ,guix-package))
+                       '())
+                 (p "To build and install " ,name " from source, run:")
+                 (pre "wget "
+                      ,(tarball-url version)
+                      "
+tar xf "
+                      ,repo "-" ,version ".tar.gz"
+                      "
+cd "
+                      ,repo "-" ,version
+                      "
+./configure
+make
+make install")))))
+      (h2 "License")
+      (p ,license)
+      (h2 "Git Repository")
+      ,@(let ((url (string-append "https://git.dthompson.us/" repo ".git")))
+          `((p ,name " is developed using the Git version control
+system. The official repository is hosted at "
+               ,(anchor url url) ".")
+            (p "To clone the repository, run:")
+            (pre "git clone " ,url)))
+      (h2 "Community")
+      (p "Real-time discussion for " ,name " can be found on the "
+         (code "#guile")
+         " channel on the Freenode IRC network.")
+      (h2 "Contributing")
+      (p "Send patches and bug reports to "
+         ,(anchor "davet@gnu.org" "mailto:davet@gnu.org")
+         ".")))
+
+  (static-page name (string-append "projects/" file-name) body))