summaryrefslogtreecommitdiff
path: root/haunt.scm
diff options
context:
space:
mode:
Diffstat (limited to 'haunt.scm')
-rw-r--r--haunt.scm367
1 files changed, 167 insertions, 200 deletions
diff --git a/haunt.scm b/haunt.scm
index 6bbc884..27acb27 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -35,6 +35,8 @@
(srfi srfi-1)
(srfi srfi-19)
(srfi srfi-26)
+ (sxml simple)
+ (sxml transform)
(haunt asset)
(haunt html)
(haunt page)
@@ -82,74 +84,35 @@ current-lingua."
(with-syntax ((current-lingua (datum->syntax x 'current-lingua)))
#'(translated-msg msg current-lingua))))))
-(define (translated-multipart-msg msg lingua assoc)
- "Looks up MSG for LINGUA via Gettext and returns a list of its parts.
+(define (translated-xml-msg msgid lingua . sxml-or-handlers)
+ "Looks up MSGID for LINGUA via Gettext and returns the result of
+transforming its XML tags with the handlers in SXML-OR-HANDLERS.
-Parts are separated by two vertical bars ||. If a part is prefixed by
-a text followed by a vertical bar the text is looked up a lambda in
-the association list ASSOC. If found, the lambda is called on the
-remainder of the part and the result added to the list. If it is not
-found or there is no vertical bar, the entire part is added to the
-list."
- (define (split-along-unescaped-matches str pattern)
- "Splits along pattern unless pattern is escaped by a backslash."
- (let loop ((remainder str) ; what to match with
- (start 0)) ; where to start matching, used to ignore
- ; escaped matches
- (let ((match (string-match pattern remainder start)))
- (if match ; if there is a match:
- (if (and
- ;; if match not at the beginning
- (not (= (match:start match) 0))
- (eq? ; and escaped by a backslash
- (string-ref
- remainder
- (- (match:start match) 1))
- #\\))
- ;; then continue matching after the escaped match:
- (loop
- (string-append ; the same as remainder but
- (string-drop-right (match:prefix match) 1) ; drop backslash
- (match:substring match)
- (match:suffix match))
- (- (match:end match) 1))
- ;; otherwise:
- (cons
- ;; everything before the match
- (match:prefix match)
- (loop ; recursive call
- (match:suffix match) ; on everything after the match
- 0))) ; start matching at start
- ;; if pattern did not match:
- (list remainder)))))
- (let ((msgstr-parts
- (split-along-unescaped-matches
- (translated-msg msg lingua)
- "\\\|\\\|")))
- (map
- (lambda (msgstr-part)
- (let* ((subparts
- (split-along-unescaped-matches
- msgstr-part
- "\\\|"))
- (from-assoc (assoc-ref assoc (car subparts)))
- (part-lambda (assoc-ref assoc (car subparts)))
- (args (cdr subparts)))
- (if part-lambda
- (if (procedure? part-lambda)
- (apply part-lambda args)
- ;; if in assoc but not a procedure, just insert it:
- from-assoc)
- msgstr-part)))
- msgstr-parts)))
+STRINGS-OR-HANDLERS is a list of pairs. The left part is the name of
+an XML tag. The right part is either a procedure transforming the
+tag and a its children into SXML or it is an SXML constant."
+ (define (sxml-or-handler->handler sxml-or-handler)
+ (if (procedure? (cdr sxml-or-handler))
+ sxml-or-handler
+ (cons (car sxml-or-handler)
+ (lambda (tag . kids) (cdr sxml-or-handler))))) ; constant function
+ (let ((wrapped-xml-msgid (string-append "<translation>"
+ (translated-msg msgid lingua)
+ "</translation>"))
+ (handlers (map sxml-or-handler->handler sxml-or-handlers)))
+ (cdadr ; cdadr unwraps the wrapped MSGID by removing XML tags outside MSGID
+ (pre-post-order (xml->sxml wrapped-xml-msgid)
+ `(,@handlers
+ (*default* . ,(lambda (tag . kids) `(,tag ,@kids)))
+ (*text* . ,(lambda (_ txt) txt)))))))
(define-syntax __
(lambda (x)
"Gettext shorthand for multipart messages separated by || in the string."
(syntax-case x ()
- ((__ msg assoc)
+ ((__ msg handler ...)
(with-syntax ((current-lingua (datum->syntax x 'current-lingua)))
- #'(translated-multipart-msg msg current-lingua assoc))))))
+ #'(translated-xml-msg msg current-lingua handler ...))))))
(define (is-post-file-name-for-lingua? file-name lingua)
(let ((beginning (string-join (list posts-dir lingua) "/" 'suffix)))
@@ -494,8 +457,8 @@ its index according to LESS-PROC."
(string-append
tag
".xml"))))
- ,@(__ "See other posts about ||descrip_||."
- `(("descrip_" . ,description))))))
+ ,@(__ "See other posts about <description/>."
+ `(description . ,description)))))
(define (tags-for-post-for-lingua post lingua)
"SXML for a list of tags of a post."
@@ -663,28 +626,33 @@ back button."
?message"))
"pelzflorian@chat.pelzflorian.de"))
(div
- ,@(__ "GnuPG key: ||gnupglink_|| (valid until \
-||gnupgexp_||)"
- `(("gnupglink_" .
- ,(a-href
- "/files/key.asc"
- "0x4947055B"))
- ("gnupgexp_" .
- "01/27/2019")))))
+ ,@(__ "GnuPG key: <gnupg-key-link/> (valid \
+until <gnupg-expiry-time/>)"
+ `(gnupg-key-link
+ . ,(a-href
+ "/files/key.asc"
+ "0x4947055B"))
+ '(gnupg-expiry-time
+ . "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))))))
+<link>here</link>."
+ `(link
+ . ,(lambda (tag 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))))))))))))))
+ ,@(__ "Powered by <link \
+url=\"https://www.gnu.org/software/guile/\">GNU Guile</link> and \
+<link url=\"https://haunt.dthompson.us/\">Haunt</link>."
+ `(link
+ . ,(lambda (tag attr text)
+ (a-href
+ (cadadr attr)
+ text)))))))))))))))
(define pelzflorian-blue-theme
;; The blog’s theme.
@@ -821,19 +789,19 @@ support") "screenshots/02-thumb.png" 224 126))
,(a-href-list-element
"/git/dont-hang/"
(_ "Current development version."))
- (li ,@(__ "aurlink_|“Don’t Hang” for Arch Linux|| and \
+ (li ,@(__ "<aurlink>“Don’t Hang” for Arch Linux</aurlink> and \
derivative GNU distributions such as \
-||parabolalink_|Parabola GNU/Linux-libre||."
- `(("aurlink_" .
- ,(lambda (text)
- (a-href
- "https://aur.archlinux.org/packages/dont-hang"
- text)))
- ("parabolalink_" .
- ,(lambda (text)
- (a-href
- "https://www.parabola.nu"
- text))))))
+<parabolalink>Parabola GNU/Linux-libre</parabolalink>."
+ `(aurlink
+ . ,(lambda (tag text)
+ (a-href
+ "https://aur.archlinux.org/packages/dont-hang"
+ text)))
+ `(parabolalink
+ . ,(lambda (tag text)
+ (a-href
+ "https://www.parabola.nu"
+ text)))))
(li
;; (a (@ (href
;; "binaries/windows/dont-hang-1.1.msi"))
@@ -856,33 +824,34 @@ home page."))
)
(h1 ,(_ "Word lists"))
(p ,@(__ "“Don’t Hang” by default uses the words from \
-the ||ic_|/usr/share/dict|| directory, but it can deal with any list of \
-expressions in a text file with one expression per line. ||samplelink_|Here|| \
-is an example word list file compiled with words from \
-||wiktionarylink_|Wiktionary’s list of 1000 basic English words|| which you \
-can use if you want simpler words. This sample word list is available under \
-the terms of ||ccbysalink_|the CC-BY-SA 3.0 Unported license||, because \
+the <ic>/usr/share/dict</ic> directory, but it can deal with any list of \
+expressions in a text file with one expression per line."
+ `(ic
+ . ,(lambda (tag text)
+ `(span (@ (class "inline-code"))
+ ,text))))
+ ,@(__ "<samplelink>Here</samplelink> is an example word list \
+file compiled with words from <wiktionarylink>Wiktionary’s list of 1000 basic \
+English words</wiktionarylink> which you can use if you want simpler words."
+ `(samplelink
+ . ,(lambda (tag text)
+ (a-href
+ "sample-word-lists/english-words.txt"
+ text)))
+ `(wiktionarylink
+ . ,(lambda (tag text)
+ (a-href
+ "https://en.wiktionary.org/wiki/Appendix: \
+1000_basic_English_words"
+ text))))
+ ,@(__ "This sample word list is available under the terms of \
+<ccbysalink>the CC-BY-SA 3.0 Unported license</ccbysalink>, because \
Wiktionary uses this license and the words are taken from there."
- `(("ic_" .
- ,(lambda (text)
- `(span (@ (class "inline-code"))
- ,text)))
- ("samplelink_" .
- ,(lambda (text)
- (a-href
- "sample-word-lists/english-words.txt"
- text)))
- ("wiktionarylink_" .
- ,(lambda (text)
- (a-href
- "https://en.wiktionary.org/wiki/Appendix: 1000_b\
-asic_English_words"
- text)))
- ("ccbysalink_" .
- ,(lambda (text)
- (a-href
- "sample-word-lists/CCBYSA-3.0-UNPORTED.txt"
- text))))))
+ `(ccbysalink
+ . ,(lambda (tag text)
+ (a-href
+ "sample-word-lists/CCBYSA-3.0-UNPORTED.txt"
+ text)))))
(p ,(_ "Please note that all words in the sample word list have \
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 \
@@ -906,65 +875,62 @@ Turkish locale."))
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 \
-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/\
+ (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
+ . ,(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 ”,
-“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)))))))
+ "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 ()
+ (define (german-string<? a b)
+ (define (strip 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 <link>here</link>."
+ `(link
+ . ,(lambda (tag text)
+ (a-href
+ "/git/theater-fuer-kappler-grundschulkinder/"
+ text)))))
,(back-button-for-lingua current-lingua)))))
(lambda (site posts)
(make-page "theater/index.html"
@@ -1046,9 +1012,9 @@ license (||ccbysalink_||)."
(p ,english-links)
(p "Deutsch:" ,german-links)))
(p
- (a-href
- "/git/gui-prog-gtk/tree/?id=f2fb450d34b8fd3b47420315547a61f7f7a6cd71"
- ,(_ "All source code for the workshop."))))))
+ ,(a-href
+ "/git/gui-prog-gtk/tree/?id=f2fb450d34b8fd3b47420315547a61f7f7a6cd71"
+ (_ "All source code for the workshop."))))))
(define (gui-prog-gtk-2017-body-for-lingua lingua)
(let ((current-lingua lingua)
@@ -1125,24 +1091,25 @@ license (||ccbysalink_||)."
(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 current-lingua)
- text))))))
+ (p ,(_ "Thank you for your interest in my workshop \
+“GUI Programming with GTK+”.")
+ " "
+ ,(if enable-registration
+ `(
+ ,(__ "To register please go <link>here</link>."
+ `(link
+ . (lambda (tag text)
+ (a-href
+ "/gui-prog-anmelden/"
+ link-text))))
+ " ")
+ '())
+ ,@(__ "For more information see <link>here</link>."
+ `(link
+ . ,(lambda (tag 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)
@@ -1259,7 +1226,7 @@ interesting things to share, I’ll put them up here.")))
#:subtitle
(lambda (tag)
(lambda (current-lingua)
- (car (__ "Recent posts for ||tag" `(("tag" . ,tag))))))
+ (__ "Recent posts for <tag/>" `(tag . ,tag))))
#:filter
(lambda (lingua)
(lambda (posts)