diff options
Diffstat (limited to 'haunt.scm')
| -rw-r--r-- | haunt.scm | 210 |
1 files changed, 210 insertions, 0 deletions
diff --git a/haunt.scm b/haunt.scm new file mode 100644 index 0000000..5180304 --- /dev/null +++ b/haunt.scm @@ -0,0 +1,210 @@ +;;; 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 skribe) + (haunt reader texinfo) + (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 (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 (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")) + "© 2015 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 (static-page file theme reader) +;; (lambda (site posts) +;; (make-page "foo.html" +;; (with-layout theme )))) + +(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 %texi-rules + `((pre . ,highlight-code) + (*text* . ,(lambda (tag str) str)) + (*default* . ,sxml-identity))) + +(define (texi->shtml port) + (let ((tree (stexi->shtml (texi-fragment->stexi port)))) + (pre-post-order tree %texi-rules))) + +(define texinfo-reader + (make-reader (make-file-extension-matcher "texi") + (lambda (file) + (call-with-input-file file + (lambda (port) + (values (read-metadata-headers port) + (texi->shtml port))))))) + +(site #:title "dthompson" + #:domain "dthompson.us" + #:default-metadata + '((author . "David Thompson") + (email . "davet@gnu.org")) + #:readers (list (make-skribe-reader #:modules '((haunt skribe utils) + (skribe-utils))) + texinfo-reader) + #:builders (list (blog #:theme dthompson-theme #:collections %collections) + (atom-feed) + (atom-feeds-by-tag) + (static-directory "css") + (static-directory "fonts") + (static-directory "images"))) |