From 2a30eb2a2d5472be3df1254d5d4d04310314e628 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 19 Mar 2021 20:10:23 -0400 Subject: Break up giant haunt.scm file into many modules. --- theme.scm | 194 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 194 insertions(+) create mode 100644 theme.scm (limited to 'theme.scm') 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 +;;; +;;; 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 +;;; . + +(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)) -- cgit v1.2.3