Break up giant haunt.scm file into many modules.

6 files changed, 704 insertions, 619 deletions

diff --git a/haunt.scm b/haunt.scm
index 807d652..ed7358f 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -1,4 +1,4 @@
-;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;; 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
@@ -18,288 +18,16 @@
              (haunt builder blog)
              (haunt builder atom)
              (haunt builder assets)
-             (haunt html)
-             (haunt page)
              (haunt post)
-             (haunt reader)
-             (haunt reader commonmark)
              (haunt site)
-             (haunt utils)
-             (commonmark)
-             (syntax-highlight)
-             (syntax-highlight scheme)
-             (syntax-highlight xml)
-             (syntax-highlight c)
-             (sxml match)
-             (sxml transform)
-             (texinfo)
-             (texinfo html)
-             (srfi srfi-1)
-             (srfi srfi-19)
-             (ice-9 rdelim)
-             (ice-9 regex)
-             (ice-9 match)
-             (web uri))
-
-(define (date year month day)
-  "Create a SRFI-19 date for the given YEAR, MONTH, DAY"
-  (let ((tzoffset (tm:gmtoff (localtime (time-second (current-time))))))
-    (make-date 0 0 0 0 day month year tzoffset)))
-
-(define (stylesheet name)
-  `(link (@ (rel "stylesheet")
-            (href ,(string-append "/css/" name ".css")))))
-
-(define* (anchor content #:optional (uri content))
-  `(a (@ (href ,uri)) ,content))
-
-(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 %piwik-code
-  '((script (@ (type "text/javascript") (src "/js/piwik.js")))
-    (noscript
-     (p (img (@ (src "//stats.dthompson.us/piwik.php?idsite=1")
-                (style "border:0;")
-                (alt "")))))))
-
-(define (link name uri)
-  `(a (@ (href ,uri)) ,name))
-
-(define* (centered-image url #:optional alt)
-  `(img (@ (class "centered-image")
-           (src ,url)
-           ,@(if alt
-                 `((alt ,alt))
-                 '()))))
-
-(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")
-                              ".")))
-              ,%piwik-code)))
-         #: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)))))
+             (markdown)
+             (projects)
+             (theme)
+             (utils))
 
 (define %collections
   `(("Recent Blog Posts" "index.html" ,posts/reverse-chronological)))
 
-(define parse-lang
-  (let ((rx (make-regexp "-*-[ ]+([a-z]*)[ ]+-*-")))
-    (lambda (port)
-      (let ((line (read-line port)))
-        (match:substring (regexp-exec rx line) 1)))))
-
-(define (maybe-highlight-code lang source)
-  (let ((lexer (match lang
-                 ('scheme lex-scheme)
-                 ('xml    lex-xml)
-                 ('c      lex-c)
-                 (_ #f))))
-    (if lexer
-        (highlights->sxml (highlight lexer source))
-        source)))
-
-(define (sxml-identity . args) args)
-
-(define (highlight-code . tree)
-  (sxml-match tree
-    ((code (@ (class ,class) . ,attrs) ,source)
-     (let ((lang (string->symbol
-                  (string-drop class (string-length "language-")))))
-       `(code (@ ,@attrs)
-             ,(maybe-highlight-code lang source))))
-    (,other other)))
-
-(define (highlight-scheme code)
-  `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))
-
-(define (raw-snippet code)
-  `(pre (code ,(if (string? code) code (read-string code)))))
-
-;; Markdown doesn't support video, so let's hack around that!  Find
-;; <img> tags with a ".webm" source and substitute a <video> tag.
-(define (media-hackery . tree)
-  (sxml-match tree
-    ((img (@ (src ,src) . ,attrs) . ,body)
-     (if (string-suffix? ".webm" src)
-         `(video (@ (src ,src) (controls "true"),@attrs) ,@body)
-         tree))))
-
-(define %commonmark-rules
-  `((code . ,highlight-code)
-    (img . ,media-hackery)
-    (*text* . ,(lambda (tag str) str))
-    (*default* . ,sxml-identity)))
-
-(define (post-process-commonmark sxml)
-  (pre-post-order sxml %commonmark-rules))
-
-(define commonmark-reader*
-  (make-reader (make-file-extension-matcher "md")
-               (lambda (file)
-                 (call-with-input-file file
-                   (lambda (port)
-                     (values (read-metadata-headers port)
-                             (post-process-commonmark
-                              (commonmark->sxml port))))))))
-
-(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))
-
 (define about-page
   (static-page
    "About Me"
@@ -307,7 +35,7 @@ system. The official repository is hosted at "
    `((h2 "Hi.")
      (p "I am a professional software developer, hobbyist gardener,
 woodworker, and drummer from Worcester, Massachusetts.")
-     (p "I am currently a DevOps engineer at " ,(anchor "Vista Higher
+     (p "I am currently a Senior DevOps engineer at " ,(anchor "Vista Higher
 Learning" "http://vistahigherlearning.com")
         ", and formerly a web developer at the "
         ,(anchor "Free Software Foundation." "https://fsf.org"))
@@ -336,347 +64,6 @@ Learning" "http://vistahigherlearning.com")
      (p ,(anchor "srt2vtt" "projects/srt2vtt.html")
         " — SRT to WebVTT subtitle converter"))))
 
-(define sly-page
-  (project-page
-   #:name "Sly"
-   #:file-name "sly.html"
-   #:description
-   `((p (strong "note: this project is no longer being developed!"))
-     (p "Sly is a fun, free software 2D/3D game engine written in "
-        ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
-     ,(centered-image "/images/sly/logo.png" "Sly fox mascot")
-     (p "Sly differentiates itself from most other game engines by encouraging
-and enabling the use of "
-        ,(anchor "live coding"
-                 "http://toplap.org/about/")
-        " and "
-        ,(anchor "functional reactive programming"
-                 "https://en.wikipedia.org/wiki/Functional_reactive_programming")
-        " techniques.  Sly provides a dynamic live coding environment
-that allows games to be built interactively and iteratively without
-ever stopping the running program.  A data structure called a “signal”
-provides a method of modeling time-varying state that is declarative,
-functional, and reactive.")
-     (p ,(centered-image "/images/sly/2048.png"))
-     (p ,(centered-image "/images/sly/mines.png")))
-   #:requirements '("GNU Guile >= 2.0.11"
-                    "guile-opengl_ >= 0.1.0"
-                    "guile-sdl_ >= 0.5.0"
-                    "SDL 1.2.x"
-                    "FreeImage >= 3.0"
-                    "GNU Scientific Library (GSL)")
-   #:license "GNU GPLv3+"
-   #:repo "sly"
-   #:manual? #t
-   #:releases
-   `(("0.1" ,(date 2015 11 12)))))
-
-(define guile-sdl2-page
-  (project-page
-   #:name "Guile-SDL2"
-   #:file-name "guile-sdl2.html"
-   #:repo "guile-sdl2"
-   #:guix-package "guile-sdl2"
-   #:description
-   `((p "Guile-SDL2 provides "
-        ,(anchor "Guile Scheme" "https://gnu.org/s/guile")
-        " bindings for the "
-        ,(anchor "SDL2" "http://libsdl.org")
-        " C shared library.  The bindings are written in pure Scheme
-using Guile's foreign function interface."))
-   #:usage
-   `((p "Guile-SDL2 provides modules in the "
-        (code "(sdl2 ...)")
-        " namespace, roughly organized how the SDL2 C header files are
-organized.  Low-level bindings are available in the"
-        (code "(sdl2 bindings ...)")
-        " namespace, but these are not recommended for normal usage.")
-     (p "Additionally, SDL2 extension library bindings are available in the
-following modules:")
-     (ul (li "SDL2_image: " (code "(sdl2 image)"))
-         (li "SDL2_mixer: " (code "(sdl2 mixer)"))
-         (li "SDL2_ttf: " (code "(sdl2 ttf)")))
-     (p "Here is a short “hello, world” example program:")
-     ,(highlight-scheme
-       "(use-modules (sdl2)
-             (sdl2 render)
-             (sdl2 surface)
-             (sdl2 video))
-
-(define (draw ren)
-  (let* ((surface (load-bmp \"hello.bmp\"))
-         (texture (surface->texture ren surface)))
-    (clear-renderer ren)
-    (render-copy ren texture)
-    (present-renderer ren)
-    (sleep 2)))
-
-(sdl-init)
-
-(call-with-window (make-window)
-  (lambda (window)
-    (call-with-renderer (make-renderer window) draw)))
-
-(sdl-quit)"))
-   #:requirements '("GNU Guile >= 2.0.9"
-                    "SDL2 >= 2.0.0"
-                    "SDL2_image >= 2.0.0"
-                    "SDL2_mixer >= 2.0.0"
-                    "SDL2_ttf >= 2.0.0"
-                    "GNU Make"
-                    "GNU pkg-config")
-   #:license "GNU LGPLv3+"
-   #:manual? #t
-   #:releases
-   `(("0.5.0" ,(date 2020 04 07))
-     ("0.4.0" ,(date 2019 06 02))
-     ("0.3.1" ,(date 2018 10 16))
-     ("0.3.0" ,(date 2018 07 10))
-     ("0.2.0" ,(date 2017 01 20))
-     ("0.1.2" ,(date 2016 08 10))
-     ("0.1.1" ,(date 2016 01 01))
-     ("0.1.0" ,(date 2015 12 22)))))
-
-(define guile-syntax-highlight-page
-  (project-page
-   #:name "guile-syntax-highlight"
-   #:file-name "guile-syntax-highlight.html"
-   #:repo "guile-syntax-highlight"
-   #:description
-   `((p "guile-syntax-highlight is a general-purpose syntax
-highlighting library for GNU Guile.  It can parse code written in
-various programming languages into a simple s-expression that can be
-easily converted to HTML (via SXML) or any other format for
-rendering."))
-   #:usage
-   (highlight-scheme
-       "(use-modules (syntax-highlight)
-             (syntax-highlight scheme)
-             (sxml simple))
-
-(define code
-  \"(define (square x) \\\"Return the square of X.\\\" (* x x))\")
-
-;; Get raw highlights list.
-(define highlighted-code
-  (highlight scheme-highlighter code))
-
-;; Convert to SXML.
-(define highlighted-sxml
-  (highlights->sxml highlighted-code))
-
-;; Write HTML to stdout.
-(display (sxml->xml highlighted-sxml))
-(newline)
-")
-   #:requirements '("GNU Guile >= 2.0"
-                    "GNU Make"
-                    "GNU pkg-config")
-   #:license "GNU LGPLv3+"
-   #:releases
-   `(("0.1" ,(date 2018 03 10)))))
-
-(define haunt-page
-  (project-page
-   #:name "Haunt"
-   #:file-name "haunt.html"
-   #:repo "haunt"
-   #:guix-package "haunt"
-   #:manual? #t
-   #:description
-   `((p "Haunt is a simple, functional, hackable static site generator
-that gives authors the ability to treat websites as Scheme programs.")
-     ,(centered-image "/images/haunt/logo.png" "crudely drawn ghost")
-     (p "By giving authors the full expressive power of Scheme, they
-are able to control every aspect of the site generation process.
-Haunt provides a simple, functional build system that can be easily
-extended for this purpose.")
-     (p "Haunt has no opinion about what markup language authors
-should use to write posts, though it comes with support for the
-popular Markdown format.  Likewise, Haunt has no opinion about how
-authors structure their sites.  Though it comes with support for
-building simple blogs or Atom feeds, authors should feel empowered to
-tweak, replace, or create builders to do things that aren't provided
-out-of-the-box."))
-   #:usage
-   `((p "Here's what a simple Haunt configuration looks like:")
-     ,(call-with-input-file "snippets/haunt.scm" highlight-scheme)
-     (p "In a new directory, save the above to a file named "
-        (code "haunt.scm") ".")
-     (p "Create a subdirectory named " (code "posts") ".")
-     (p "Add the following to a new file named " (code "posts/hello.md") ":")
-     ,(call-with-input-file "snippets/haunt-hello.md" raw-snippet)
-     (p "Run " (code "haunt build") " to build the site.")
-     (p "Run " (code "haunt serve") " to a launch a web server to
-preview your work.")
-     (p "Open " ,(anchor "http://localhost:8080") " in your web browser
-and smile, because you've just generated your first Haunt site!"))
-   #:requirements
-   '("GNU Guile >= 2.0"
-     "guile-commonmark (for Markdown support, optional)"
-     "guile-reader (for Skribe support, optional)")
-   #:license "GNU GPLv3+"
-   #:releases
-   `(("0.2.4" ,(date 2018 11 29))
-     ("0.2.3" ,(date 2018 11 25))
-     ("0.2.2" ,(date 2018 03 10))
-     ("0.2.1" ,(date 2017 01 23))
-     ("0.2"   ,(date 2016 04 24))
-     ("0.1"   ,(date 2015 08 08)))))
-
-(define chickadee-page
-  (project-page
-   #:name "Chickadee"
-   #:file-name "chickadee.html"
-   #:repo "chickadee"
-   #:guix-package "guile-chickadee"
-   #:manual? #t
-   #:description
-   `((p "Chickadee is a game development toolkit for "
-        ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
-     ,(centered-image "/images/chickadee/logo.png" "Chickadee logo")
-     (p "Chickadee provides all the essential tools that
-parenthetically inclined game developers need to make games in
-Scheme.")
-     (p "Here is the obligatory “Hello, world” program:")
-     ,(highlight-scheme
-       "(use-modules (chickadee)
-             (chickadee math vector)
-             (chickadee graphics font))
-
-(define (draw alpha)
-  (draw-text \"Hello, world!\" (vec2 260.0 240.0)))
-
-(run-game #:draw draw)
-")
-     (p "And here's how to draw a sprite:")
-     ,(highlight-scheme
-       "(use-modules (chickadee)
-             (chickadee math vector)
-             (chickadee graphics sprite)
-             (chickadee graphics texture))
-
-(define sprite #f)
-
-(define (load)
-  (set! sprite (load-image \"images/chickadee.png\")))
-
-(define (draw alpha)
-  (draw-sprite sprite (vec2 256.0 176.0)))
-
-(run-game #:load load #:draw draw)
-")
-     (p "Features include:")
-     (ul
-      (li "extensible, fixed-timestep game loop")
-      (li "OpenGL-based rendering engine")
-      (li "keyboard, mouse, controller input events")
-      (li "vectors, matrices, bounding boxes, easing functions, etc.")
-      (li "asynchronous scripting"))
-     (p (small ,(anchor "chickadee sprite by Refuzzle, CC0"
-                        "http://opengameart.org/content/winter-birds"))))
-   #:requirements '("GNU Guile >= 2.1.4"
-                    "Guile-SDL2 >= 0.2.0"
-                    "Guile-OpenGL >= 0.1.0")
-   #:license "GNU GPLv3+"
-   #:releases
-   `(("0.6.0" ,(date 2020 11 19))
-     ("0.5.0" ,(date 2020 04 08))
-     ("0.4.0" ,(date 2019 06 04))
-     ("0.3.0" ,(date 2018 10 03))
-     ("0.2.0" ,(date 2017 01 26))
-     ("0.1.0" ,(date 2017 01 23)))))
-
-(define shroud-page
-  (project-page
-   #:name "Shroud"
-   #:file-name "shroud.html"
-   #:repo "shroud"
-   #:description
-   `((p "Shroud is a simple secret manager with a command line interface.")
-     (p "The password database is stored as a Scheme s-expression
-and encrypted with a "
-           ,(anchor "GnuPG" "https://gnupg.org")
-           " key.  Secrets consist of an arbitrary number of key/value
-pairs, making Shroud suitable for more than just password storage.
-For copying and pasting secrets into web browsers and other graphical
-applications, there is xclip integration."))
-   #:requirements '("GNU Guile >= 2.0.9"
-                    "GnuPG >= 1.4"
-                    "GNU Make"
-                    "GNU pkg-config"
-                    ("optional: xclip is needed for the "
-                     (code "-c")
-                     " flag of "
-                     (code "shroud show")
-                     " to work"))
-   #:usage
-   `((p "First, create a " (code ".shroud")
-        " file in your home directory to hold your
-configuration settings.  All you really need to set here is your GPG
-user ID i.e. your email address:")
-     ,(highlight-scheme
-       "'((user-id . \"foo@example.com\"))")
-     (p "The "
-        (code ".shroud")
-        " file is Scheme source code, so any expression that evaluates
-to an alist of valid configuration settings is usable by Shroud.")
-     (p "Once Shroud is configured, try out the following commands to
-get a feel for how things work:")
-     (pre
-       "# Add a new secret:
-shroud hide bank-account username=foobar password=hackme
-
-# Edit an existing secret:
-shroud hide --edit bank-account password=hackmepls
-
-# List all secrets:
-shroud list
-
-# Show all key/value pairs for a saved secret:
-shroud show bank-account
-
-# Show a single value in a secret:
-shroud show bank-account password
-
-# Copy a password directly to X clipboard:
-shroud show -c bank-account password
-
-# Delete a secret:
-shroud remove bank-account")
-     (p "Happy shrouding!"))
-   #:license "GNU GPLv3+"
-   #:releases
-   `(("0.1.1" ,(date 2015 10 01))
-     ("0.1.0" ,(date 2015 09 29)))))
-
-(define srt2vtt-page
-  (project-page
-   #:name "srt2vtt"
-   #:file-name "srt2vtt.html"
-   #:repo "srt2vtt"
-   #:description
-   `((p "Convert SRT formatted subtitles to WebVTT format for use with
-the HTML5 "
-        (code "<track>") " tag."))
-   #:requirements '("GNU Guile >= 2.0.5")
-   #:usage
-   `((pre
-      "$ srt2vtt --help
-Usage: srt2vtt [OPTIONS]
-Convert SubRip formatted subtitles to WebVTT format.
-
-  -h, --help             display this help and exit
-  -v, --version          display version and exit
-  -i, --input=FILE-NAME  read input from FILE-NAME
-  -o, --output=FILE-NAME write output to FILE-NAME")
-     (p "If " (code "--input")
-        " or " (code "--output")
-        " is ommitted, read from stdin or stdout, respectively."))
-   #:license "GNU GPLv3+"
-   #:releases
-   `(("0.1" ,(date 2015 02 7)))))
-
 (site #:title "dthompson"
       #:domain "dthompson.us"
       #:default-metadata
diff --git a/highlight.scm b/highlight.scm
new file mode 100644
index 0000000..51f2b02
--- /dev/null
+++ b/highlight.scm
@@ -0,0 +1,31 @@
+(define-module (highlight)
+  #:use-module (ice-9 match)
+  #:use-module (sxml match)
+  #:use-module (syntax-highlight)
+  #:use-module (syntax-highlight scheme)
+  #:use-module (syntax-highlight xml)
+  #:use-module (syntax-highlight c)
+  #:export (highlight-code
+            highlight-scheme))
+
+(define (maybe-highlight-code lang source)
+  (let ((lexer (match lang
+                 ('scheme lex-scheme)
+                 ('xml    lex-xml)
+                 ('c      lex-c)
+                 (_ #f))))
+    (if lexer
+        (highlights->sxml (highlight lexer source))
+        source)))
+
+(define (highlight-code . tree)
+  (sxml-match tree
+    ((code (@ (class ,class) . ,attrs) ,source)
+     (let ((lang (string->symbol
+                  (string-drop class (string-length "language-")))))
+       `(code (@ ,@attrs)
+             ,(maybe-highlight-code lang source))))
+    (,other other)))
+
+(define (highlight-scheme code)
+  `(pre (code ,(highlights->sxml (highlight lex-scheme code)))))
diff --git a/markdown.scm b/markdown.scm
new file mode 100644
index 0000000..d1a70b4
--- /dev/null
+++ b/markdown.scm
@@ -0,0 +1,53 @@
+;;; 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 (markdown)
+  #:use-module (commonmark)
+  #:use-module (haunt post)
+  #:use-module (haunt reader)
+  #:use-module (highlight)
+  #:use-module (sxml match)
+  #:use-module (sxml transform)
+  #:export (commonmark-reader*))
+
+(define (sxml-identity . args) args)
+
+;; Markdown doesn't support video, so let's hack around that!  Find
+;; <img> tags with a ".webm" source and substitute a <video> tag.
+(define (media-hackery . tree)
+  (sxml-match tree
+    ((img (@ (src ,src) . ,attrs) . ,body)
+     (if (string-suffix? ".webm" src)
+         `(video (@ (src ,src) (controls "true"),@attrs) ,@body)
+         tree))))
+
+(define %commonmark-rules
+  `((code . ,highlight-code)
+    (img . ,media-hackery)
+    (*text* . ,(lambda (tag str) str))
+    (*default* . ,sxml-identity)))
+
+(define (post-process-commonmark sxml)
+  (pre-post-order sxml %commonmark-rules))
+
+(define commonmark-reader*
+  (make-reader (make-file-extension-matcher "md")
+               (lambda (file)
+                 (call-with-input-file file
+                   (lambda (port)
+                     (values (read-metadata-headers port)
+                             (post-process-commonmark
+                              (commonmark->sxml port))))))))
diff --git a/projects.scm b/projects.scm
new file mode 100644
index 0000000..e2b672e
--- /dev/null
+++ b/projects.scm
@@ -0,0 +1,369 @@
+;;; 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 (projects)
+  #:use-module (highlight)
+  #:use-module (theme)
+  #:use-module (utils)
+  #:export (chickadee-page
+            sly-page
+            guile-sdl2-page
+            guile-syntax-highlight-page
+            haunt-page
+            shroud-page
+            srt2vtt-page))
+
+(define sly-page
+  (project-page
+   #:name "Sly"
+   #:file-name "sly.html"
+   #:description
+   `((p (strong "note: this project is no longer being developed!"))
+     (p "Sly is a fun, free software 2D/3D game engine written in "
+        ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
+     ,(centered-image "/images/sly/logo.png" "Sly fox mascot")
+     (p "Sly differentiates itself from most other game engines by encouraging
+and enabling the use of "
+        ,(anchor "live coding"
+                 "http://toplap.org/about/")
+        " and "
+        ,(anchor "functional reactive programming"
+                 "https://en.wikipedia.org/wiki/Functional_reactive_programming")
+        " techniques.  Sly provides a dynamic live coding environment
+that allows games to be built interactively and iteratively without
+ever stopping the running program.  A data structure called a “signal”
+provides a method of modeling time-varying state that is declarative,
+functional, and reactive.")
+     (p ,(centered-image "/images/sly/2048.png"))
+     (p ,(centered-image "/images/sly/mines.png")))
+   #:requirements '("GNU Guile >= 2.0.11"
+                    "guile-opengl_ >= 0.1.0"
+                    "guile-sdl_ >= 0.5.0"
+                    "SDL 1.2.x"
+                    "FreeImage >= 3.0"
+                    "GNU Scientific Library (GSL)")
+   #:license "GNU GPLv3+"
+   #:repo "sly"
+   #:manual? #t
+   #:releases
+   `(("0.1" ,(date 2015 11 12)))))
+
+(define guile-sdl2-page
+  (project-page
+   #:name "Guile-SDL2"
+   #:file-name "guile-sdl2.html"
+   #:repo "guile-sdl2"
+   #:guix-package "guile-sdl2"
+   #:description
+   `((p "Guile-SDL2 provides "
+        ,(anchor "Guile Scheme" "https://gnu.org/s/guile")
+        " bindings for the "
+        ,(anchor "SDL2" "http://libsdl.org")
+        " C shared library.  The bindings are written in pure Scheme
+using Guile's foreign function interface."))
+   #:usage
+   `((p "Guile-SDL2 provides modules in the "
+        (code "(sdl2 ...)")
+        " namespace, roughly organized how the SDL2 C header files are
+organized.  Low-level bindings are available in the"
+        (code "(sdl2 bindings ...)")
+        " namespace, but these are not recommended for normal usage.")
+     (p "Additionally, SDL2 extension library bindings are available in the
+following modules:")
+     (ul (li "SDL2_image: " (code "(sdl2 image)"))
+         (li "SDL2_mixer: " (code "(sdl2 mixer)"))
+         (li "SDL2_ttf: " (code "(sdl2 ttf)")))
+     (p "Here is a short “hello, world” example program:")
+     ,(highlight-scheme
+       "(use-modules (sdl2)
+             (sdl2 render)
+             (sdl2 surface)
+             (sdl2 video))
+
+(define (draw ren)
+  (let* ((surface (load-bmp \"hello.bmp\"))
+         (texture (surface->texture ren surface)))
+    (clear-renderer ren)
+    (render-copy ren texture)
+    (present-renderer ren)
+    (sleep 2)))
+
+(sdl-init)
+
+(call-with-window (make-window)
+  (lambda (window)
+    (call-with-renderer (make-renderer window) draw)))
+
+(sdl-quit)"))
+   #:requirements '("GNU Guile >= 2.0.9"
+                    "SDL2 >= 2.0.0"
+                    "SDL2_image >= 2.0.0"
+                    "SDL2_mixer >= 2.0.0"
+                    "SDL2_ttf >= 2.0.0"
+                    "GNU Make"
+                    "GNU pkg-config")
+   #:license "GNU LGPLv3+"
+   #:manual? #t
+   #:releases
+   `(("0.5.0" ,(date 2020 04 07))
+     ("0.4.0" ,(date 2019 06 02))
+     ("0.3.1" ,(date 2018 10 16))
+     ("0.3.0" ,(date 2018 07 10))
+     ("0.2.0" ,(date 2017 01 20))
+     ("0.1.2" ,(date 2016 08 10))
+     ("0.1.1" ,(date 2016 01 01))
+     ("0.1.0" ,(date 2015 12 22)))))
+
+(define guile-syntax-highlight-page
+  (project-page
+   #:name "guile-syntax-highlight"
+   #:file-name "guile-syntax-highlight.html"
+   #:repo "guile-syntax-highlight"
+   #:description
+   `((p "guile-syntax-highlight is a general-purpose syntax
+highlighting library for GNU Guile.  It can parse code written in
+various programming languages into a simple s-expression that can be
+easily converted to HTML (via SXML) or any other format for
+rendering."))
+   #:usage
+   (highlight-scheme
+    "(use-modules (syntax-highlight)
+             (syntax-highlight scheme)
+             (sxml simple))
+
+(define code
+  \"(define (square x) \\\"Return the square of X.\\\" (* x x))\")
+
+;; Get raw highlights list.
+(define highlighted-code
+  (highlight scheme-highlighter code))
+
+;; Convert to SXML.
+(define highlighted-sxml
+  (highlights->sxml highlighted-code))
+
+;; Write HTML to stdout.
+(display (sxml->xml highlighted-sxml))
+(newline)
+")
+   #:requirements '("GNU Guile >= 2.0"
+                    "GNU Make"
+                    "GNU pkg-config")
+   #:license "GNU LGPLv3+"
+   #:releases
+   `(("0.1" ,(date 2018 03 10)))))
+
+(define haunt-page
+  (project-page
+   #:name "Haunt"
+   #:file-name "haunt.html"
+   #:repo "haunt"
+   #:guix-package "haunt"
+   #:manual? #t
+   #:description
+   `((p "Haunt is a simple, functional, hackable static site generator
+that gives authors the ability to treat websites as Scheme programs.")
+     ,(centered-image "/images/haunt/logo.png" "crudely drawn ghost")
+     (p "By giving authors the full expressive power of Scheme, they
+are able to control every aspect of the site generation process.
+Haunt provides a simple, functional build system that can be easily
+extended for this purpose.")
+     (p "Haunt has no opinion about what markup language authors
+should use to write posts, though it comes with support for the
+popular Markdown format.  Likewise, Haunt has no opinion about how
+authors structure their sites.  Though it comes with support for
+building simple blogs or Atom feeds, authors should feel empowered to
+tweak, replace, or create builders to do things that aren't provided
+out-of-the-box."))
+   #:usage
+   `((p "Here's what a simple Haunt configuration looks like:")
+     ,(call-with-input-file "snippets/haunt.scm" highlight-scheme)
+     (p "In a new directory, save the above to a file named "
+        (code "haunt.scm") ".")
+     (p "Create a subdirectory named " (code "posts") ".")
+     (p "Add the following to a new file named " (code "posts/hello.md") ":")
+     ,(call-with-input-file "snippets/haunt-hello.md" raw-snippet)
+     (p "Run " (code "haunt build") " to build the site.")
+     (p "Run " (code "haunt serve") " to a launch a web server to
+preview your work.")
+     (p "Open " ,(anchor "http://localhost:8080") " in your web browser
+and smile, because you've just generated your first Haunt site!"))
+   #:requirements
+   '("GNU Guile >= 2.0"
+     "guile-commonmark (for Markdown support, optional)"
+     "guile-reader (for Skribe support, optional)")
+   #:license "GNU GPLv3+"
+   #:releases
+   `(("0.2.4" ,(date 2018 11 29))
+     ("0.2.3" ,(date 2018 11 25))
+     ("0.2.2" ,(date 2018 03 10))
+     ("0.2.1" ,(date 2017 01 23))
+     ("0.2"   ,(date 2016 04 24))
+     ("0.1"   ,(date 2015 08 08)))))
+
+(define chickadee-page
+  (project-page
+   #:name "Chickadee"
+   #:file-name "chickadee.html"
+   #:repo "chickadee"
+   #:guix-package "guile-chickadee"
+   #:manual? #t
+   #:description
+   `((p "Chickadee is a game development toolkit for "
+        ,(anchor "Guile Scheme" "https://gnu.org/s/guile") ".")
+     ,(centered-image "/images/chickadee/logo.png" "Chickadee logo")
+     (p "Chickadee provides all the essential tools that
+parenthetically inclined game developers need to make games in
+Scheme.")
+     (p "Here is the obligatory “Hello, world” program:")
+     ,(highlight-scheme
+       "(use-modules (chickadee)
+             (chickadee math vector)
+             (chickadee graphics font))
+
+(define (draw alpha)
+  (draw-text \"Hello, world!\" (vec2 260.0 240.0)))
+
+(run-game #:draw draw)
+")
+     (p "And here's how to draw a sprite:")
+     ,(highlight-scheme
+       "(use-modules (chickadee)
+             (chickadee math vector)
+             (chickadee graphics sprite)
+             (chickadee graphics texture))
+
+(define sprite #f)
+
+(define (load)
+  (set! sprite (load-image \"images/chickadee.png\")))
+
+(define (draw alpha)
+  (draw-sprite sprite (vec2 256.0 176.0)))
+
+(run-game #:load load #:draw draw)
+")
+     (p "Features include:")
+     (ul
+      (li "extensible, fixed-timestep game loop")
+      (li "OpenGL-based rendering engine")
+      (li "keyboard, mouse, controller input events")
+      (li "vectors, matrices, bounding boxes, easing functions, etc.")
+      (li "asynchronous scripting"))
+     (p (small ,(anchor "chickadee sprite by Refuzzle, CC0"
+                        "http://opengameart.org/content/winter-birds"))))
+   #:requirements '("GNU Guile >= 2.1.4"
+                    "Guile-SDL2 >= 0.2.0"
+                    "Guile-OpenGL >= 0.1.0")
+   #:license "GNU GPLv3+"
+   #:releases
+   `(("0.6.0" ,(date 2020 11 19))
+     ("0.5.0" ,(date 2020 04 08))
+     ("0.4.0" ,(date 2019 06 04))
+     ("0.3.0" ,(date 2018 10 03))
+     ("0.2.0" ,(date 2017 01 26))
+     ("0.1.0" ,(date 2017 01 23)))))
+
+(define shroud-page
+  (project-page
+   #:name "Shroud"
+   #:file-name "shroud.html"
+   #:repo "shroud"
+   #:description
+   `((p "Shroud is a simple secret manager with a command line interface.")
+     (p "The password database is stored as a Scheme s-expression
+and encrypted with a "
+        ,(anchor "GnuPG" "https://gnupg.org")
+        " key.  Secrets consist of an arbitrary number of key/value
+pairs, making Shroud suitable for more than just password storage.
+For copying and pasting secrets into web browsers and other graphical
+applications, there is xclip integration."))
+   #:requirements '("GNU Guile >= 2.0.9"
+                    "GnuPG >= 1.4"
+                    "GNU Make"
+                    "GNU pkg-config"
+                    ("optional: xclip is needed for the "
+                     (code "-c")
+                     " flag of "
+                     (code "shroud show")
+                     " to work"))
+   #:usage
+   `((p "First, create a " (code ".shroud")
+        " file in your home directory to hold your
+configuration settings.  All you really need to set here is your GPG
+user ID i.e. your email address:")
+     ,(highlight-scheme
+       "'((user-id . \"foo@example.com\"))")
+     (p "The "
+        (code ".shroud")
+        " file is Scheme source code, so any expression that evaluates
+to an alist of valid configuration settings is usable by Shroud.")
+     (p "Once Shroud is configured, try out the following commands to
+get a feel for how things work:")
+     (pre
+      "# Add a new secret:
+shroud hide bank-account username=foobar password=hackme
+
+# Edit an existing secret:
+shroud hide --edit bank-account password=hackmepls
+
+# List all secrets:
+shroud list
+
+# Show all key/value pairs for a saved secret:
+shroud show bank-account
+
+# Show a single value in a secret:
+shroud show bank-account password
+
+# Copy a password directly to X clipboard:
+shroud show -c bank-account password
+
+# Delete a secret:
+shroud remove bank-account")
+     (p "Happy shrouding!"))
+   #:license "GNU GPLv3+"
+   #:releases
+   `(("0.1.1" ,(date 2015 10 01))
+     ("0.1.0" ,(date 2015 09 29)))))
+
+(define srt2vtt-page
+  (project-page
+   #:name "srt2vtt"
+   #:file-name "srt2vtt.html"
+   #:repo "srt2vtt"
+   #:description
+   `((p "Convert SRT formatted subtitles to WebVTT format for use with
+the HTML5 "
+        (code "<track>") " tag."))
+   #:requirements '("GNU Guile >= 2.0.5")
+   #:usage
+   `((pre
+      "$ srt2vtt --help
+Usage: srt2vtt [OPTIONS]
+Convert SubRip formatted subtitles to WebVTT format.
+
+  -h, --help             display this help and exit
+  -v, --version          display version and exit
+  -i, --input=FILE-NAME  read input from FILE-NAME
+  -o, --output=FILE-NAME write output to FILE-NAME")
+     (p "If " (code "--input")
+        " or " (code "--output")
+        " is ommitted, read from stdin or stdout, respectively."))
+   #:license "GNU GPLv3+"
+   #:releases
+   `(("0.2" ,(date 2021 03 19))
+     ("0.1" ,(date 2015 02 7)))))
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))
diff --git a/utils.scm b/utils.scm
new file mode 100644
index 0000000..7b64cdc
--- /dev/null
+++ b/utils.scm
@@ -0,0 +1,51 @@
+;;; 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 (utils)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-19)
+  #:export (date
+            stylesheet
+            anchor
+            link
+            centered-image
+            raw-snippet)
+  #:replace (link))
+
+(define (date year month day)
+  "Create a SRFI-19 date for the given YEAR, MONTH, DAY"
+  (let ((tzoffset (tm:gmtoff (localtime (time-second (current-time))))))
+    (make-date 0 0 0 0 day month year tzoffset)))
+
+(define (stylesheet name)
+  `(link (@ (rel "stylesheet")
+            (href ,(string-append "/css/" name ".css")))))
+
+(define* (anchor content #:optional (uri content))
+  `(a (@ (href ,uri)) ,content))
+
+(define (link name uri)
+  `(a (@ (href ,uri)) ,name))
+
+(define* (centered-image url #:optional alt)
+  `(img (@ (class "centered-image")
+           (src ,url)
+           ,@(if alt
+                 `((alt ,alt))
+                 '()))))
+
+(define (raw-snippet code)
+  `(pre (code ,(if (string? code) code (read-string code)))))