summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFlorian Pelz <pelzflorian@pelzflorian.de>2018-02-08 15:48:35 +0100
committerFlorian Pelz <pelzflorian@pelzflorian.de>2018-02-08 15:48:35 +0100
commit02e80b47fe0a9929a25d4a5f7ce11a15e1042d6f (patch)
treec9d5b56261deb53bcf0457e666851dc4e705281e
parent4394ed0ce1bdb2662028459bc6ceb3620f81002c (diff)
Adapt to use page variants.
This uses my patches discussed here: https://lists.gnu.org/archive/html/guix-devel/2018-02/msg00118.html
-rw-r--r--haunt.scm908
1 files changed, 479 insertions, 429 deletions
diff --git a/haunt.scm b/haunt.scm
index 44a64ea..7162ea4 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -1,5 +1,5 @@
;;; pelzflorian.de website sources.
-;;; Copyright © 2017 Florian Pelz
+;;; Copyright © 2017, 2018 Florian Pelz
;;;
;;; 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
@@ -39,6 +39,7 @@
(ice-9 regex)
(srfi srfi-1)
(srfi srfi-19)
+ (srfi srfi-26)
(haunt asset)
(haunt html)
(haunt page)
@@ -270,6 +271,27 @@ list."
(with-syntax ((current-lingua (datum->syntax x 'current-lingua)))
#'(translated-multipart-msg msg current-lingua assoc))))))
+(define (is-post-file-name-for-lingua? file-name lingua)
+ (let ((beginning (string-join (list posts-dir lingua) "/" 'suffix)))
+ (string=? (string-take file-name (string-length beginning))
+ beginning)))
+
+(define (is-post-for-lingua? post lingua)
+ (is-post-file-name-for-lingua? (post-file-name post) lingua))
+
+(define (posts-for-lingua posts lingua)
+ (let* ((posts-relative-dirname
+ (string-join (list posts-dir lingua) "/"))
+ (lingua-filter-regexp
+ (make-regexp
+ (string-append "^" posts-relative-dirname)))
+ (lingua-filter
+ (lambda (post)
+ (let ((file-path (post-file-name post)))
+ (regexp-match?
+ (regexp-exec lingua-filter-regexp file-path))))))
+ (filter lingua-filter posts)))
+
(define (date->string-for-lingua date lingua)
"Custom date->string* variant that deals with lingua and my no longer common \
German language orthographic preferences."
@@ -630,231 +652,242 @@ its index according to LESS-PROC."
,(post-sxml post)))
"")) ; don’t print any posts if there are no posts yet
-(define* (pelzflorian-blue-layout current-lingua #:optional (is-homepage? #f))
+(define* (pelzflorian-blue-layout #:optional (is-homepage? #f))
"Template layout for all the blog’s pages. If is-homepage is set, shows no \
back button."
(lambda (site title body)
- (define (link-to-css filename)
- `(link
- (@ (rel "stylesheet")
- (type "text/css")
- (href ,(build-url css-dir filename)))))
- (define (link-to-feed lingua)
- (let ((current-lingua lingua))
+ (lambda (current-lingua)
+ (define (link-to-css filename)
`(link
- (@ (rel "alternate")
- (type "application/atom+xml")
- ;; TODO Gettext *should* pass the following on into the
- ;; pot file but does not. Why?
- ;; TRANSLATORS: This should be the current language.
- (title ,(_ "My blog in English"))
- (hreflang ,lingua)
- (href
- ,(build-url feeds-dir lingua "feed.xml"))))))
- `((doctype "html")
- (html
- (@ (lang ,(_ "@ietf-lang-tag")))
- (head
- (meta (@ (charset "utf-8")))
- ;; remove ASAP once @viewport becomes normative in CSS:
- (meta (@ (name "viewport")
- (content "width=device-width, initial-scale=1")))
- (title ,(string-join `(,title "–" ,(site-title site))))
- (link
- (@ (rel "icon")
- (type "image/png")
- (href
- ,(build-url image-dir "favicon.png"))))
- ;; reference Atom feeds for all linguas, current lingua on top
- ,(link-to-feed current-lingua)
- ,(map (lambda (lingua)
- (if (not (equal? lingua current-lingua))
- (link-to-feed lingua)
- ""))
- linguas)
- ,(link-to-css "common.css"))
- (body
- (div (@ (id "top-bar"))
- (div (@ (id "name-div"))
- ,(site-title site))
- (div (@ (id "top-div"))
- (div (@ (id "linguas-div"))
- ,(map (lambda (lingua)
- `(span (@ (class "horizontally-padded"))
- ,(if (equal? lingua current-lingua)
- lingua
- (a-href
- ;; TODO LINK TO CORRESPONDING PAGE
- (string-append
- "/"
- "index-"
- lingua
- ".html")
- lingua))))
- linguas))))
- (div (@ (id "center"))
- (nav (@ (id "side-bar"))
- ,(if (not is-homepage?)
- (back-button-for-lingua current-lingua)
- "")
- (div (@ (id "link-div"))
- (ul
- ,(a-href-sidebar-element
- "/git/"
- (_ "Git Projects"))
- ,(a-href-sidebar-element
- (string-append
- "/dont-hang/index-"
- current-lingua
- ".html")
- (_ "Don’t Hang"))
- ,(a-href-sidebar-element
- (string-append
- "/theater/index-"
- current-lingua
- ".html")
- (_ "Theater für Kappler Grundschulkinder"))
- ,(a-href-sidebar-element
- (string-append
- "/old-stuff-"
- current-lingua
- ".html")
- (_ "Old stuff"))
- ,(a-href-sidebar-element
- (string-append
- "/gui-prog-gtk-2017/index-"
- current-lingua
- ".html")
- (_ "GTK+ Workshop 2017"))
- ,(a-href-sidebar-element
- (string-append
- "/gui-prog-gtk-2016/index-"
- current-lingua
- ".html")
- (_ "GTK+ Workshop 2016"))
- ,(a-href-sidebar-element
- (build-url feeds-dir current-lingua "feed.xml")
- (_ "Subscribe to Atom feed")))))
- (div (@ (id "content"))
- ,body
- (footer
- (div (@ (id "contact"))
- (h1
- (@ (class "contact-heading"))
- ,(_ "Contact me:"))
- (div
- ,(_ "Mail:")
- " "
- (a (@ (href "mailto:pelzflorian@pelzflorian.de"))
- "pelzflorian@pelzflorian.de"))
- (div
- "XMPP:"
- " "
- (a
- (@
- (href
- "xmpp:pelzflorian@chat.pelzflorian.de?message"))
- "pelzflorian@chat.pelzflorian.de"))
- (div
- ,@(__ "GnuPG key: ||gnupglink_|| (valid until \
+ (@ (rel "stylesheet")
+ (type "text/css")
+ (href ,(build-url css-dir filename)))))
+ (define (link-to-feed lingua)
+ (let ((current-lingua lingua))
+ `(link
+ (@ (rel "alternate")
+ (type "application/atom+xml")
+ ;; TODO Gettext *should* pass the following on into the
+ ;; pot file but does not. Why? TRANSLATORS: This
+ ;; should be the current language.
+ (title ,(_ "My blog in English"))
+ (hreflang ,lingua)
+ (href
+ ,(build-url feeds-dir lingua "feed.xml"))))))
+ (if (not (body current-lingua))
+ #f
+ ;; otherwise:
+ `((doctype "html")
+ (html
+ (@ (lang ,(_ "@ietf-lang-tag")))
+ (head
+ (meta (@ (charset "utf-8")))
+ ;; remove ASAP once @viewport becomes normative in CSS:
+ (meta (@ (name "viewport")
+ (content "width=device-width, initial-scale=1")))
+ (title ,(let ((title-of-page (if (procedure? title)
+ (title current-lingua)
+ title)))
+ (string-join `(,title-of-page "–" ,(site-title site)))))
+ (link
+ (@ (rel "icon")
+ (type "image/png")
+ (href
+ ,(build-url image-dir "favicon.png"))))
+ ;; reference Atom feeds for all linguas, current lingua on top
+ ,(link-to-feed current-lingua)
+ ,(map (lambda (lingua)
+ (if (not (equal? lingua current-lingua))
+ (link-to-feed lingua)
+ ""))
+ linguas)
+ ,(link-to-css "common.css"))
+ (body
+ (div (@ (id "top-bar"))
+ (div (@ (id "name-div"))
+ ,(site-title site))
+ (div (@ (id "top-div"))
+ (div (@ (id "linguas-div"))
+ ,(map (lambda (lingua)
+ `(span (@ (class "horizontally-padded"))
+ ,(if (equal? lingua current-lingua)
+ lingua
+ (a-href
+ ;; TODO LINK TO CORRESPONDING PAGE
+ (string-append
+ "/"
+ "index-"
+ lingua
+ ".html")
+ lingua))))
+ linguas))))
+ (div (@ (id "center"))
+ (nav (@ (id "side-bar"))
+ ,(if (not is-homepage?)
+ (back-button-for-lingua current-lingua)
+ "")
+ (div (@ (id "link-div"))
+ (ul
+ ,(a-href-sidebar-element
+ "/git/"
+ (_ "Git Projects"))
+ ,(a-href-sidebar-element
+ (string-append
+ "/dont-hang/index-"
+ current-lingua
+ ".html")
+ (_ "Don’t Hang"))
+ ,(a-href-sidebar-element
+ (string-append
+ "/theater/index-"
+ current-lingua
+ ".html")
+ (_ "Theater für Kappler Grundschulkinder"))
+ ,(a-href-sidebar-element
+ (string-append
+ "/old-stuff-"
+ current-lingua
+ ".html")
+ (_ "Old stuff"))
+ ,(a-href-sidebar-element
+ (string-append
+ "/gui-prog-gtk-2017/index-"
+ current-lingua
+ ".html")
+ (_ "GTK+ Workshop 2017"))
+ ,(a-href-sidebar-element
+ (string-append
+ "/gui-prog-gtk-2016/index-"
+ current-lingua
+ ".html")
+ (_ "GTK+ Workshop 2016"))
+ ,(a-href-sidebar-element
+ (build-url feeds-dir current-lingua "feed.xml")
+ (_ "Subscribe to Atom feed")))))
+ (div (@ (id "content"))
+ ,(body current-lingua)
+ (footer
+ (div (@ (id "contact"))
+ (h1
+ (@ (class "contact-heading"))
+ ,(_ "Contact me:"))
+ (div
+ ,(_ "Mail:")
+ " "
+ (a (@ (href "mailto:pelzflorian@pelzflorian.de"))
+ "pelzflorian@pelzflorian.de"))
+ (div
+ "XMPP:"
+ " "
+ (a (@(href "xmpp:pelzflorian@chat.pelzflorian.de\
+?message"))
+ "pelzflorian@chat.pelzflorian.de"))
+ (div
+ ,@(__ "GnuPG key: ||gnupglink_|| (valid until \
||gnupgexp_||)"
- `(("gnupglink_" .
- ,(a-href
- "/files/key.asc"
- "0x4947055B"))
- ("gnupgexp_" .
- "01/27/2019")))))
- (div (@ (id "source-code-link"))
- ,@(__ "Find the source code for this website \
+ `(("gnupglink_" .
+ ,(a-href
+ "/files/key.asc"
+ "0x4947055B"))
+ ("gnupgexp_" .
+ "01/27/2019")))))
+ (div (@ (id "source-code-link"))
+ ,@(__ "Find the source code for this website \
||link_|here||."
- `(("link_" .
- ,(lambda (text)
- `(a (@ (href ,(build-url
- "git"
- "pelzfloriande-website")))
- ,text))))))
- (div (@ (id "powered-by"))
- ,@(__ "Powered by \
+ `(("link_" .
+ ,(lambda (text)
+ `(a (@ (href ,(build-url
+ "git"
+ "pelzfloriande-website")))
+ ,text))))))
+ (div (@ (id "powered-by"))
+ ,@(__ "Powered by \
||link_|https://www.gnu.org/software/guile/|GNU Guile|| and \
||link_|https://haunt.dthompson.us/|Haunt||."
- `(("link_" . ,a-href))))))))))))
+ `(("link_" . ,a-href))))))))))))))
-(define (pelzflorian-blue-theme current-lingua)
- "Returns the blog’s theme for the lingua."
+(define pelzflorian-blue-theme
+ ;; The blog’s theme.
(theme #:name "Pelzflorian Blue"
#:layout
- (pelzflorian-blue-layout current-lingua)
+ (pelzflorian-blue-layout)
#:post-template
(lambda (post)
- `(div
- (h1 ,(post-ref post 'title))
- (h2 ,(date->string-for-lingua (post-date post) current-lingua))
- (div ,(post-sxml post))
- ,(tags-for-post-for-lingua post current-lingua)
- (div (@ (class "vertically-padded"))
- ,(recent-post-link-for-lingua current-lingua))
- (div (@ (class "vertically-padded"))
- ,(back-button-for-lingua current-lingua))))
+ (lambda (current-lingua)
+ (if (not (is-post-for-lingua? post current-lingua))
+ #f
+ `(div
+ (h1 ,(post-ref post 'title))
+ (h2 ,(date->string-for-lingua
+ (post-date post) current-lingua))
+ (div ,(post-sxml post))
+ ,(tags-for-post-for-lingua post current-lingua)
+ (div (@ (class "vertically-padded"))
+ ,(recent-post-link-for-lingua current-lingua))
+ (div (@ (class "vertically-padded"))
+ ,(back-button-for-lingua current-lingua))))))
#:collection-template
(lambda (site title posts prefix)
- `(div
- (h1 ,(_ "Recent posts"))
- (ol
- ,@(map (lambda (post)
- `(li
- (a (@ (href
- ,(build-url posts-dir
- current-lingua
- (string-append
- (post-slug post)
- ".html")))
- (class "full-width-link"))
- ,(string-append
- (post-ref post 'title)
- " ("
- (date->string-for-lingua
- (post-date post)
- current-lingua)
- ")"))))
- (posts/reverse-chronological posts)))
- ,(back-button-for-lingua current-lingua)))))
+ (lambda (current-lingua)
+ `(div
+ (h1 ,(_ "Recent posts"))
+ (ol
+ ,@(map (lambda (post)
+ `(li
+ (a (@ (href
+ ,(build-url posts-dir
+ current-lingua
+ (string-append
+ (post-slug post)
+ ".html")))
+ (class "full-width-link"))
+ ,(string-append
+ (post-ref post 'title)
+ " ("
+ (date->string-for-lingua
+ (post-date post)
+ current-lingua)
+ ")"))))
+ (posts/reverse-chronological
+ (posts-for-lingua posts current-lingua))))
+ ,(back-button-for-lingua current-lingua))))))
-(define (old-stuff-page-for-lingua lingua)
- (let* ((current-lingua lingua)
- (body
- `(div
- (h1 ,(_ "Lecture notes"))
- (div ,(_ "Some German lecture summaries I made for lectures I \
+(define old-stuff-page
+ (let ((body
+ (lambda (current-lingua)
+ `(div
+ (h1 ,(_ "Lecture notes"))
+ (div ,(_ "Some German lecture summaries I made for lectures I \
heard in 2013:"))
- (ul
- ,(a-href-multi-list-element
- '(("Pdf" . "/uni/fp_zusammenfassung.pdf")
- ("Tex" . "/uni/fp_zusammenfassung.tex"))
- "Logik")
- ,(a-href-multi-list-element
- '(("Pdf" . "/uni/insy_noticen.pdf")
- ("Tex" . "/uni/insy_noticen.tex"))
- "Insy"))
- (h1 ,(_ "C exercises (German)"))
- (p ,(_ "Includes a cheat sheet for working with C."))
- (ul
- ,(a-href-list-element
- "/c_exercises.htm"
- (_ "C Exercises")))
- ,(back-button-for-lingua lingua))))
+ (ul
+ ,(a-href-multi-list-element
+ '(("Pdf" . "/uni/fp_zusammenfassung.pdf")
+ ("Tex" . "/uni/fp_zusammenfassung.tex"))
+ "Logik")
+ ,(a-href-multi-list-element
+ '(("Pdf" . "/uni/insy_noticen.pdf")
+ ("Tex" . "/uni/insy_noticen.tex"))
+ "Insy"))
+ (h1 ,(_ "C exercises (German)"))
+ (p ,(_ "Includes a cheat sheet for working with C."))
+ (ul
+ ,(a-href-list-element
+ "/c_exercises.htm"
+ (_ "C Exercises")))
+ ,(back-button-for-lingua current-lingua)))))
(lambda (site posts)
- (make-page (string-append "old-stuff" "-" lingua ".html")
+ (make-page "old-stuff.html"
(with-layout
- (pelzflorian-blue-theme lingua)
+ pelzflorian-blue-theme
site
- (_ "Old stuff")
+ (lambda (current-lingua) (_ "Old stuff"))
body)
sxml->html))))
-(define (dont-hang-page-for-lingua lingua)
- (let ((current-lingua lingua))
- (lambda (site posts)
- (let ((body
+(define dont-hang-page
+ (lambda (site posts)
+ (let ((body
+ (lambda (current-lingua)
`(div
(h1 ,(_ "Don’t Hang"))
@@ -880,7 +913,9 @@ support") "screenshots/02-thumb.png" 224 126))
,(let* ((posts-about-dont-hang
(assoc-ref
- (posts/group-by-tag posts) "dont-hang")))
+ (posts/group-by-tag
+ (posts-for-lingua posts current-lingua))
+ "dont-hang")))
(if (and posts-about-dont-hang
(not (null? posts-about-dont-hang)))
(let ((most-recent-post-about-dont-hang
@@ -920,24 +955,24 @@ derivative GNU distributions such as \
"https://www.parabola.nu"
text))))))
(li
- ;; (a (@ (href
- ;; "binaries/windows/dont-hang-1.1.msi"))
- ;; ,(_ "Windows installer (x86)"))
- ;; ,(_ " as well as ")
- (a (@ (href
- "binaries/windows/dont-hang-1.1.zip"))
- ,(_ "“portable” binaries without installer"))
- ,(_ " if you are still using Windows, all built using ")
- (a (@ (href "http://www.msys2.org")) "MSYS2")
- ,(_ " for which the source files are available at their
+ ;; (a (@ (href
+ ;; "binaries/windows/dont-hang-1.1.msi"))
+ ;; ,(_ "Windows installer (x86)"))
+ ;; ,(_ " as well as ")
+ (a (@ (href
+ "binaries/windows/dont-hang-1.1.zip"))
+ ,(_ "“portable” binaries without installer"))
+ ,(_ " if you are still using Windows, all built using ")
+ (a (@ (href "http://www.msys2.org")) "MSYS2")
+ ,(_ " for which the source files are available at their
home page."))
-;; (li ,(_ "Unsigned ")
-;; (a (@ (href
-;; "binaries/macos/dont-hang-1.1.dmg"))
-;; ,(_ "macOS binaries (10.10 Yosemite or newer)"))
-;; ,(_ " if you are still using macOS (you may need to \
-;; follow the instructions from the macOS error messages on how to make \
-;; macOS trust the binaries)."))
+;;; (li ,(_ "Unsigned ")
+;;; (a (@ (href
+;;; "binaries/macos/dont-hang-1.1.dmg"))
+;;; ,(_ "macOS binaries (10.10 Yosemite or newer)"))
+;;; ,(_ " if you are still using macOS (you may need to \
+;;; follow the instructions from the macOS error messages on how to make \
+;;; macOS trust the binaries)."))
)
(h1 ,(_ "Word lists"))
(p ,@(__ "“Don’t Hang” by default uses the words from \
@@ -973,92 +1008,92 @@ been deliberately converted to upper case. The reason is that “Don’t Hang”
displays words in upper case and storing the words in lower case would lead to \
errors in some locales, e.g. the English word “is” would become “İS” in a \
Turkish locale."))
- ,(back-button-for-lingua lingua))))
- (make-page (string-append "dont-hang/index" "-" lingua ".html")
- (with-layout
- (pelzflorian-blue-theme lingua)
- site
- (_ "Don’t Hang")
- body)
- sxml->html)))))
+ ,(back-button-for-lingua current-lingua)))))
+ (make-page "dont-hang/index.html"
+ (with-layout
+ pelzflorian-blue-theme
+ site
+ (lambda (current-lingua) (_ "Don’t Hang"))
+ body)
+ sxml->html))))
-(define (schulstücke-page-for-lingua lingua)
- (let ((current-lingua lingua))
- (lambda (site posts)
- (let ((body
- `(div
- (h1 ,(_ "Theater for elementary school kids from Kappel"))
- (p ,(_ "This is a collection of theater plays by my \
+(define schulstücke-page
+ (let ((body
+ (lambda (current-lingua)
+ `(div
+ (h1 ,(_ "Theater for elementary school kids from Kappel"))
+ (p ,(_ "This is a collection of theater plays by my \
grandmother Elfriede Pelz. She was an elementary school teacher in Kappel in \
the German city of Freiburg im Breisgau and not only taught her students how \
to read but also valued a clear pronunciation."))
- (p ,@(__ "You may want to take a look at the plays if you \
+ (p ,@(__ "You may want to take a look at the plays if you \
speak German or want to learn German. They are available under a free \
license (||ccbysalink_||)."
- `(("ccbysalink_" .
- ,(lambda ()
- (a-href
- "https://creativecommons.org/licenses/by-sa/\
+ `(("ccbysalink_" .
+ ,(lambda ()
+ (a-href
+ "https://creativecommons.org/licenses/by-sa/\
4.0/legalcode.de"
- "CC-BY-SA 4.0")))))
- (div (@ (class "vertically-padded centered"))
- ,(a-href "theater-fuer-kappler-grundschulkinder.pdf"
- (_ "Download")))
- ,(sortable-table-for-lingua
- `((,(_ "Play no.") ,(_ "Title"))
- ("1" "Kasperlespiel zum Schulanfang 1989")
- ("2" "Kasperle und der Zauberer vom Kybfelsen")
- ("3" "Dornröschen")
- ("4" "Mondfahrt in geheimer Mission")
- ("5" "Das tapfere Schneiderlein")
- ("6" "Der Teufel mit den drei goldenen Haaren")
- ("7" "Wie Eulenspiegel die Kranken heilte")
- ("8" ,(string-append
- "Das erste Weihnachtslied"
- (format #f (_ " (by ~A)")
- "Franz Pelz"))))
- (let ((german-string<?
- (lambda (a b)
- (let ((strip
- (lambda (string)
- "Strips off “Der ”, “Die ”, “Das ”,
+ "CC-BY-SA 4.0")))))
+ (div (@ (class "vertically-padded centered"))
+ ,(a-href "theater-fuer-kappler-grundschulkinder.pdf"
+ (_ "Download")))
+ ,(sortable-table-for-lingua
+ `((,(_ "Play no.") ,(_ "Title"))
+ ("1" "Kasperlespiel zum Schulanfang 1989")
+ ("2" "Kasperle und der Zauberer vom Kybfelsen")
+ ("3" "Dornröschen")
+ ("4" "Mondfahrt in geheimer Mission")
+ ("5" "Das tapfere Schneiderlein")
+ ("6" "Der Teufel mit den drei goldenen Haaren")
+ ("7" "Wie Eulenspiegel die Kranken heilte")
+ ("8" ,(string-append
+ "Das erste Weihnachtslied"
+ (format #f (_ " (by ~A)")
+ "Franz Pelz"))))
+ (let ((german-string<?
+ (lambda (a b)
+ (let ((strip
+ (lambda (string)
+ "Strips off “Der ”, “Die ”, “Das ”,
“Eine ”, “Ein ” from the beginning of a string."
- (cond
- ((and (> (string-length string) 4)
- (member
- (string-take string 4)
- '("Der " "Die " "Das "
- "Ein ")))
- (string-drop string 4))
- ((and (> (string-length string) 5)
- (member
- (string-take string 5)
- '("Eine ")))
- (string-drop string 5))
- (else string)))))
- (string-locale<?
- (strip a)
- (strip b)
- (make-locale LC_ALL "de_DE.UTF-8"))))))
- `(,german-string<? ,german-string<?))
- (_ "Table of contents")
- current-lingua)
- (img (@ (src "by-sa.svg")
- (alt "CC-BY-SA logo")))
- (p ,@(__ "Get the source code ||gitlink_|here||."
- `(("gitlink_" .
- ,(lambda (text)
- (a-href
- "/git/theater-fuer-kappler-grundschulkinder/"
- text)))))))
- ,(back-button-for-lingua lingua))))
- (make-page (string-append "theater/index" "-" lingua ".html")
- (with-layout
- (pelzflorian-blue-theme lingua)
- site
- "Theater für Kappler Grundschulkinder"
- body)
- sxml->html)))))
+ (cond
+ ((and (> (string-length string) 4)
+ (member
+ (string-take string 4)
+ '("Der " "Die " "Das "
+ "Ein ")))
+ (string-drop string 4))
+ ((and (> (string-length string) 5)
+ (member
+ (string-take string 5)
+ '("Eine ")))
+ (string-drop string 5))
+ (else string)))))
+ (string-locale<?
+ (strip a)
+ (strip b)
+ (make-locale LC_ALL "de_DE.UTF-8"))))))
+ `(,german-string<? ,german-string<?))
+ (_ "Table of contents")
+ current-lingua)
+ (img (@ (src "by-sa.svg")
+ (alt "CC-BY-SA logo")))
+ (p ,@(__ "Get the source code ||gitlink_|here||."
+ `(("gitlink_" .
+ ,(lambda (text)
+ (a-href
+ "/git/theater-fuer-kappler-grundschulkinder/"
+ text)))))))
+ ,(back-button-for-lingua current-lingua)))))
+ (lambda (site posts)
+ (make-page "theater/index.html"
+ (with-layout
+ pelzflorian-blue-theme
+ site
+ "Theater für Kappler Grundschulkinder"
+ body)
+ sxml->html))))
;;; GUI Programming in GTK+ Workshop lambdas yielding bodies:
@@ -1202,142 +1237,105 @@ license (||ccbysalink_||)."
"/git/gui-prog-gtk/"))
,(_ "All source code for the workshop."))))))
-(define (gui-prog-gtk-page-for-lingua
- lingua
+(define (gui-prog-gtk-page
gui-prog-gtk-body-for-lingua ; lambda yielding list of download links
year ; workshop year for HTML title
poster-url-for-lingua ; for link to poster
enable-registration) ; whether to show registration link
- (let ((current-lingua lingua))
- (lambda (site posts)
- (let ((body
- `(div
- (p ,@(__ "Thank you for your interest in my workshop \
+ (let ((body
+ (lambda (current-lingua)
+ `(div
+ (p ,@(__ "Thank you for your interest in my workshop \
“GUI Programming with GTK+”. ||register_|To register please go |here|. ||For \
more information see ||link_|here||."
- `(("register_" .
- ,(lambda (before-link link-text after-link)
- (if enable-registration
- `(span
- ,before-link
- ,(a-href
- "/gui-prog-anmelden/"
- link-text)
- ,after-link)
- "")))
- ("link_" .
- ,(lambda (text)
- (a-href
- (poster-url-for-lingua lingua)
- text))))))
- ,(gui-prog-gtk-body-for-lingua current-lingua)
- ,(back-button-for-lingua current-lingua))))
- (make-page
- (string-append "gui-prog-gtk-" year "/index" "-" lingua ".html")
- (with-layout
- (pelzflorian-blue-theme lingua)
- site
- (string-append (_ "GUI Programming with GTK+ ") year)
- body)
- sxml->html)))))
-
-(define (homepage-for-lingua lingua)
- (let ((current-lingua lingua))
+ `(("register_" .
+ ,(lambda (before-link link-text after-link)
+ (if enable-registration
+ `(span
+ ,before-link
+ ,(a-href
+ "/gui-prog-anmelden/"
+ link-text)
+ ,after-link)
+ "")))
+ ("link_" .
+ ,(lambda (text)
+ (a-href
+ (poster-url-for-lingua current-lingua)
+ text))))))
+ ,(gui-prog-gtk-body-for-lingua current-lingua)
+ ,(back-button-for-lingua current-lingua)))))
(lambda (site posts)
- (let ((most-recent-post
- (if (null? posts)
- #f
- (car (posts/reverse-chronological posts)))))
- (make-page (string-append "index" "-" lingua ".html")
- ((pelzflorian-blue-layout lingua #t) ; #t means
- ; “use layout
- ; variant for
- ; homepage”
- site
- (_ "Home page")
- `(div
- (div
- (h1 ,(_ "Welcome"))
- (p ,(_ "Welcome to my personal web site. My name is \
+ (make-page
+ (string-append "gui-prog-gtk-" year "/index.html")
+ (with-layout
+ pelzflorian-blue-theme
+ site
+ (lambda (current-lingua)
+ (string-append (_ "GUI Programming with GTK+ ") year))
+ body)
+ sxml->html))))
+
+(define homepage
+ (lambda (site posts)
+ (define (most-recent-post lingua)
+ (let ((lingua-posts (posts-for-lingua posts lingua)))
+ (if (null? lingua-posts)
+ #f
+ (car (posts/reverse-chronological lingua-posts)))))
+ (make-page "index.html"
+ ((pelzflorian-blue-layout #t) ; #t means “use layout
+ ; variant for homepage”
+ site
+ (lambda (current-lingua) (_ "Home page"))
+ (lambda (current-lingua)
+ `(div
+ (div
+ (h1 ,(_ "Welcome"))
+ (p ,(_ "Welcome to my personal web site. My name is \
Florian Pelz and I live in Kaiserslautern in Germany. When I have \
interesting things to share, I’ll put them up here.")))
- ,(if (not (null? posts))
- `(div
- ,(format-post-for-lingua
- most-recent-post
- current-lingua)
- (div
- ,(tags-for-post-for-lingua
- most-recent-post
- current-lingua)
- ,(recent-post-link-for-lingua current-lingua)))
- ""))) ; don’t print any posts if there are
- ; no posts yet
- sxml->html)))))
+ ,(if (not (null? posts))
+ `(div
+ ,(format-post-for-lingua
+ (most-recent-post current-lingua)
+ current-lingua)
+ (div
+ ,(tags-for-post-for-lingua
+ (most-recent-post current-lingua)
+ current-lingua)
+ ,(recent-post-link-for-lingua current-lingua)))
+ "")))) ; don’t print any posts if there are
+ ; no posts yet
+ sxml->html)))
-(define (builders-for-lingua lingua)
- "Returns all the site builders specific to lingua."
- (let* ((current-lingua lingua)
- (posts-relative-dirname
- (string-join (list posts-dir lingua) "/"))
- (feeds-relative-dirname
- (string-join (list feeds-dir lingua) "/"))
- (lingua-filter-regexp
- (make-regexp
- (string-append "^" posts-relative-dirname)))
- (lingua-filter
- (lambda (post)
- (let ((file-path (post-file-name post)))
- (regexp-match?
- (regexp-exec lingua-filter-regexp file-path))))))
- (lambda (site posts)
- (let ((posts-for-lingua (filter lingua-filter posts))
- (blog-for-lingua
- (blog
- #:theme (pelzflorian-blue-theme lingua)
- #:prefix posts-relative-dirname
- #:collections `((,(_ "Recent posts")
- "index.html"
- ,posts/reverse-chronological))))
- (atom-feed-for-lingua
- (atom-feed
- #:file-name (string-join
- (list feeds-relative-dirname "feed.xml")
- "/")
- #:subtitle (_ "Recent posts")
- #:blog-prefix (string-append "/" posts-relative-dirname)))
- (atom-feeds-by-tag-for-lingua
- (atom-feeds-by-tag
- #:prefix feeds-relative-dirname
- #:blog-prefix (string-append "/" posts-relative-dirname))))
- (flatten ; flatten the resulting list, i.e. no nested elements
- (append ; ensure every argument is a list:
- (list (blog-for-lingua site posts-for-lingua))
- (list (atom-feed-for-lingua site posts-for-lingua))
- (list (atom-feeds-by-tag-for-lingua site posts-for-lingua))
- (list (make-asset "c_exercises.htm" "c_exercises.htm"))
- (list (make-asset "c_exercises.css" "c_exercises.css"))
- (list ((dont-hang-page-for-lingua lingua) site posts-for-lingua))
- (list ((schulstücke-page-for-lingua lingua) site posts-for-lingua))
- (list ((old-stuff-page-for-lingua lingua) site posts-for-lingua))
- (list ((gui-prog-gtk-page-for-lingua
- lingua
- gui-prog-gtk-2016-body-for-lingua
- "2016"
- (lambda (lingua) "gui-prog-poster.pdf")
- #f) ; #f means registration is disabled
- site
- posts-for-lingua))
- (list ((gui-prog-gtk-page-for-lingua
- lingua
- gui-prog-gtk-2017-body-for-lingua
- "2017"
- (lambda (lingua)
- (string-append "gui-prog-poster-" lingua ".pdf"))
- #f)
- site
- posts-for-lingua))
- (list ((homepage-for-lingua lingua) site posts-for-lingua))))))))
+(define (my-variant-namer variant base-file-name)
+ (define (put-variant-after-prefix prefix)
+ (string-join (list prefix variant
+ (string-drop base-file-name
+ (1+ (string-length prefix))))
+ "/"))
+ (cond
+ ((string-prefix? (string-append posts-dir "/") base-file-name)
+ (put-variant-after-prefix posts-dir))
+ ((string-prefix? (string-append feeds-dir "/") base-file-name)
+ (put-variant-after-prefix feeds-dir))
+ (else
+ (let ((period-index
+ (string-rindex base-file-name #\.)))
+ (if period-index
+ (string-append
+ (string-take base-file-name
+ period-index)
+ "-"
+ variant
+ "."
+ (string-drop base-file-name
+ (1+ period-index)))
+ (string-append
+ base-file-name
+ "."
+ variant))))))
(site #:title "pelzflorian.de"
#:domain "pelzflorian.de"
@@ -1350,7 +1348,7 @@ interesting things to share, I’ll put them up here.")))
;;; (email . "pelzflorian@pelzflorian.de"))
#:readers (list sxml-reader)
#:builders
- (cons*
+ (list
(static-directory css-dir)
(static-directory files-dir)
(static-directory image-dir)
@@ -1361,7 +1359,59 @@ interesting things to share, I’ll put them up here.")))
(static-directory "gui-prog-gtk-2017")
(static-directory "maumau")
(static-directory "theater")
- (map ; list of other pages and assets
+ (blog
+ #:theme pelzflorian-blue-theme
+ #:prefix posts-dir
+ #:collections
+ `((,(lambda (current-lingua) (_ "Recent posts"))
+ "index.html"
+ ,posts/reverse-chronological)))
+ (atom-feed
+ #:file-name
+ (string-join
+ (list feeds-dir "feed.xml")
+ "/")
+ #:subtitle (lambda (current-lingua) (_ "Recent posts"))
+ #:filter (lambda (lingua) (cut posts-for-lingua <> lingua))
+ #:blog-prefix (string-append "/" posts-dir))
+ (atom-feeds-by-tag
+ #:prefix feeds-dir
+ #:subtitle
+ (lambda (tag)
+ (lambda (current-lingua)
+ (car (__ "Recent posts for ||tag" `(("tag" . ,tag))))))
+ #:filter
(lambda (lingua)
- (builders-for-lingua lingua))
- linguas)))
+ (lambda (posts)
+ (let ((filtered-posts (posts-for-lingua posts lingua)))
+ (if (null? filtered-posts)
+ #f
+ filtered-posts))))
+ #:blog-prefix (string-append "/" posts-dir))
+ (lambda (site posts) ; A site builder for all other pages.
+ (list
+ (make-asset "c_exercises.htm" "c_exercises.htm")
+ (make-asset "c_exercises.css" "c_exercises.css")
+ (dont-hang-page site posts)
+ (schulstücke-page site posts)
+ (old-stuff-page site posts)
+ ((gui-prog-gtk-page
+ gui-prog-gtk-2016-body-for-lingua
+ "2016"
+ (lambda (lingua) "gui-prog-poster.pdf")
+ #f) ; #f means registration is disabled
+ site
+ posts)
+ ((gui-prog-gtk-page
+ gui-prog-gtk-2017-body-for-lingua
+ "2017"
+ (lambda (lingua)
+ (string-append "gui-prog-poster-" lingua ".pdf"))
+ #f)
+ site
+ posts)
+ (homepage site posts))))
+ #:variants
+ linguas
+ #:variant-namer
+ my-variant-namer)