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
|
;;; GuixSD website --- GNU's advanced distro website
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GuixSD website.
;;;
;;; GuixSD website is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GuixSD website 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 Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public License
;;; along with GuixSD website. If not, see <http://www.gnu.org/licenses/>.
(define-module (www news)
#:use-module (www utils)
#:use-module (www shared)
#:use-module (haunt site)
#:use-module (haunt post)
#:use-module (haunt builder blog)
#:use-module (syntax-highlight)
#:use-module (syntax-highlight scheme)
#:use-module (syntax-highlight lexers)
#:use-module (ice-9 match)
#:use-module (srfi srfi-19)
#:export (post-url
%news-haunt-theme))
(define (post-url post site)
"Return the URL of POST, a Haunt blog post, for SITE."
(base-url (string-append "news/" (site-post-slug site post) ".html")))
(define %default-special-prefixes
'("define" "syntax"))
(define lex-scheme/guix
;; Specialized lexer for the Scheme we use in Guix.
;; TODO: Add #~, #$, etc.
(make-scheme-lexer (cons* "with-imported-modules"
"gexp" "ungexp"
"ungexp-native" "ungexp-splicing"
"ungexp-native-splicing"
"mlet" "mlet*"
"match"
%default-special-symbols)
%default-special-prefixes))
(define (syntax-highlight sxml)
"Recurse over SXML and syntax-highlight code snippets."
(match sxml
(('code ('@ ('class "language-scheme")) code-snippet)
`(code ,(highlights->sxml
(highlight lex-scheme/guix code-snippet))))
((tag ('@ attributes ...) body ...)
`(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
((tag body ...)
`(,tag ,@(map syntax-highlight body)))
((? string? str)
str)))
(define* (post->sxml post #:key post-uri)
"Return the SXML for POST."
`(div (h2 (@ (class "title"))
,(if post-uri
`(a (@ (href ,post-uri))
,(post-ref post 'title))
(post-ref post 'title)))
(div (@ (class "post-about"))
,(post-ref post 'author)
" — " ,(date->string (post-date post) "~B ~e, ~Y"))
(div (@ (class "post-body"))
,(syntax-highlight (post-sxml post)))))
(define (news-page-sxml site title posts prefix)
"Return the SXML for the news page of SITE, containing POSTS."
`((div (@ (class "news-header"))
(h1 "Recent News "
(a (@ (href ,(base-url "news/feed.xml")))
(img (@ (alt "Atom feed")
(src ,(image-url "feed.png")))))))
(div (@ (class "post-list"))
,@(map (lambda (post)
(post->sxml post #:post-uri (post-url post site)))
posts))))
(define (base-layout body)
`((doctype "html")
(html (@ (lang "en"))
,(html-page-header "News" #:css "news.css")
(body
,(html-page-description)
,(html-page-links)
(div (@ (id "content-box"))
(article ,body))
,(html-page-footer)))))
(define %news-haunt-theme
;; Theme for the rendering of the news pages.
(theme #:name "GuixSD"
#:layout (lambda (site title body)
(base-layout body))
#:post-template post->sxml
#:collection-template news-page-sxml))
|