1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This file is part of Haunt.
;;;
;;; Haunt 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.
;;;
;;; Haunt 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 Haunt. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Page builders
;;
;;; Code:
(define-module (haunt builder blog)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (haunt site)
#:use-module (haunt post)
#:use-module (haunt page)
#:use-module (haunt utils)
#:use-module (haunt html)
#:export (theme
theme?
theme-name
theme-layout
theme-post-template
theme-list-template
blog))
(define-record-type <theme>
(make-theme name layout post-template list-template)
theme?
(name theme-name)
(layout theme-layout)
(post-template theme-post-template)
(list-template theme-list-template))
(define* (theme #:key
(name "Untitled")
layout
post-template
list-template)
(make-theme name layout post-template list-template))
(define (with-layout theme site title body)
((theme-layout theme) site title body))
(define (render-post theme site post)
(let ((title (post-ref post 'title))
(body ((theme-post-template theme) post)))
(with-layout theme site title body)))
(define (render-list theme site title posts prefix)
(let ((body ((theme-list-template theme) site title posts prefix)))
(with-layout theme site title body)))
(define (date->string* date)
"Convert DATE to human readable string."
(date->string date "~a ~d ~B ~Y"))
(define ugly-theme
(theme #:name "Ugly"
#:layout
(lambda (site title body)
`((doctype "html")
(head
(meta (@ (charset "utf-8")))
(title ,(string-append title " — " (site-title site))))
(body
(h1 ,(site-title site))
,body)))
#:post-template
(lambda (post)
`((h2 ,(post-ref post 'title))
(h3 "by " ,(post-ref post 'author)
" — " ,(date->string* (post-date post)))
(div ,(post-sxml post))))
#:list-template
(lambda (site title posts prefix)
(define (post-uri post)
(string-append "/" (or prefix "")
(site-post-slug site post) ".html"))
`((h3 ,title)
(ul
,@(map (lambda (post)
`(li
(a (@ (href ,(post-uri post)))
,(post-ref post 'title)
" — "
,(date->string* (post-date post)))))
posts))))))
(define* (blog #:key (theme ugly-theme) prefix)
"Return a procedure that transforms a list of posts into pages
decorated by THEME, whose URLs start with PREFIX."
(define (make-file-name base-name)
(if prefix
(string-append prefix "/" base-name)
base-name))
(lambda (site posts)
(define (post->page post)
(let ((base-name (string-append (site-post-slug site post)
".html")))
(make-page (make-file-name base-name)
(render-post theme site post)
sxml->html)))
(define index-page
(make-page (make-file-name "index.html")
(render-list theme site "Recent Posts"
(posts/reverse-chronological posts)
prefix)
sxml->html))
(cons index-page (map post->page posts))))
|
