path: root/haunt.scm

;;; Copyright © 2015 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 (add-to-load-path* directory)
  (unless (member directory %load-path)
    (add-to-load-path directory)))

(add-to-load-path* "/home/dave/Code/guile-syntax-highlight")

(use-modules (haunt asset)
             (haunt builder blog)
             (haunt builder atom)
             (haunt builder assets)
             (haunt html)
             (haunt page)
             (haunt post)
             (haunt reader)
             (haunt reader commonmark)
             (haunt site)
             (haunt utils)
             (syntax-highlight)
             (syntax-highlight scheme)
             (sxml match)
             (sxml transform)
             (texinfo)
             (texinfo html)
             (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 uri)
  `(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=3")
                (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"))
                              "© 2016 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 "http://haunt.dthompson.us"))
                                 "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)
             ,(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 %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 source)
  (call-with-input-string source
    (lambda (port)
      (let ((lang (string->symbol (parse-lang port))))
        (if lang
            (highlights->sxml
             (highlight (match lang
                          ('scheme lex-scheme)
                          ('xml    lex-xml))
                        port))
            source)))))

(define (sxml-identity . args) args)

(define (highlight-code . tree)
  (sxml-match tree
    ((pre (@ . ,attrs) ,source)
     `(pre (@ ,@attrs)
           ,(maybe-highlight-code source)))))

(define (highlight-scheme code)
  `(pre ,(highlights->sxml (highlight lex-scheme code))))

(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)
  (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 (string-append "https://files.dthompson.us/"
                                             repo "/" repo "-" version
                                             ".tar.gz")))
                     `(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)
            `((p ,name " uses the standard GNU build system.  "
                 "To build and install " ,name " from source, run:")
              (pre "./configure
make
make install")))
      (h2 "License")
      (p ,license)
      (h2 "Source Code")
      ,@(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))
            (h3 "Anonymous clone")
            (pre "git clone " ,url)))
      (h2 "Community")
      (p "Real-time discussion for Guile-SDL2 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"
   "about.html"
   `((h2 "Hi.")
     (p "I am a professional software developer and free software
activist based in Massachusetts.")
     (p "I graudated from "
        ,(anchor "Worcester State University" "http://worcester.edu")
        " in 2012 with a BS in Computer Science.")
     (p "I am currently a web developer with a focus on operations
at "
        ,(anchor "Vista Higher Learning" "http://vistahigherlearning.com")
        ", and formerly a web developer at the "
        ,(anchor "Free Software Foundation." "https://fsf.org"))
     (p "You can follow me on "
        ,(anchor "GNU Social" "https://quitter.se/davexunit") " and "
        ,(anchor "Twitter" "https://twitter.com/davexunit") "."))))

(define projects-page
  (static-page
   "Projects"
   "projects.html"
   `((h1 "Projects")
     (p ,(anchor "Guile-SDL2" "projects/guile-sdl2.html")
        " — SDL2 bindings for Guile Scheme")
     (p ,(anchor "Haunt" "projects/haunt.html")
        " — Functional, hackable static site generator")
     (p ,(anchor "Shroud" "projects/shroud.html")
        " — GPG-based password manager")
     (p ,(anchor "Sly" "projects/sly.html")
        " — Functional reactive game engine")
     (p ,(anchor "srt2vtt" "projects/srt2vtt.html")
        " — SRT to WebVTT subtitle converter"))))

(define sly-page
  (project-page
   #:name "Sly"
   #:file-name "sly.html"
   #:description
   `((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"
   #: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, bu 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+"
   #:releases
   `(("0.1.2" ,(date 2016 08 10))
     ("0.1.1" ,(date 2016 01 01))
     ("0.1.0" ,(date 2015 12 22)))))

(site #:title "dthompson"
      #:domain "dthompson.us"
      #:default-metadata
      '((author . "David Thompson")
        (email  . "davet@gnu.org"))
      #:readers (list commonmark-reader)
      #:builders (list (blog #:theme dthompson-theme #:collections %collections)
                       (atom-feed)
                       (atom-feeds-by-tag)
                       about-page
                       projects-page
                       sly-page
                       guile-sdl2-page
                       (static-directory "css")
                       (static-directory "fonts")
                       (static-directory "images")
                       (static-directory "src")
                       (static-directory "manuals")))