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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
;;; Harmonic Flow web site
(define-module (apps blog utils)
#:use-module (apps aux lists)
#:use-module (apps aux web)
#:use-module (apps i18n)
#:use-module (haunt post)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (syntax-highlight)
#:use-module (syntax-highlight scheme)
#:use-module (syntax-highlight lexers)
#:export (post-groups->tag-list
post-url-path
posts/latest
syntax-highlight
change-image-to-video
tag-first?
tag-system-path
tag-url-path))
(define (post-groups->tag-list groups)
"Return a list of Haunt tags from the list of grouped posts.
GROUPS (association list)
An association list of tags mapped to posts, as returned by the
posts/group-by-tag procedure from (haunt post) module."
(cond ((null? groups) '())
(else
(cons (car (first groups))
(post-groups->tag-list (rest groups))))))
(define (post-url-path post)
"Return a URL path for the POST in the form blog/YYYY/POST-SLUG.
POST (<post>)
A post object as defined in (haunt post) module."
;; Note: End the path with a slash so 'localized-root-path' down the road
;; prepends the language tag.
(url-path-join "blog"
(date->string (post-date post) "~Y")
(post-slug post)
""))
(define (posts/latest posts n)
"Return the latest N posts from the given list of posts."
(let ((latest-posts (posts/reverse-chronological posts)))
(cond
((null? posts) '())
((<= (length posts) n) latest-posts)
(else (list-head latest-posts n)))))
(define (tag-first? tag-a tag-b)
"Return true if TAG-A goes first than TAG-B alphabetically.
This predicate is used for sorting tags.
TAG-A, TAG-B (string)
A tag as used by Haunt posts. For example: 'User interface'."
(string<? (string-downcase tag-a) (string-downcase tag-b)))
(define (tag-system-path tag)
"Return a system path for the TAG in the form blog/tags/TAG-SLUG.
The path is relative to the website directory.
TAG (string)
A tag as used by Haunt posts. For example: 'Scheme API'."
(string-append "blog/tags/" (slugify tag)))
(define (tag-url-path tag)
"Return a URL path for the TAG in the form blog/tags/TAG-SLUG.
TAG (string)
A tag as used by Haunt posts. For example: 'Scheme API'."
;; Note: End the path with a slash so 'localized-root-path' down the road
;; prepends the language tag.
(url-path-join "blog" "tags" (slugify tag) ""))
;;;
;;; Syntax highlighting.
;;;
(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
;; sceheme:
;;(('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 (change-image-to-video sxml)
"Replace <img> tags in SXML that refer to WebM videos with proper <video>
tags. This hack allows one to refer to a video from a Markdown document."
(match sxml
(('img ('@ attributes ...) body ...)
(let ((src (match (assoc 'src attributes)
((_ url) url)))
(alt (match (assoc 'alt attributes)
((_ text) text))))
(if (string-suffix? ".webm" src)
`(video (@ (src ,src)
(poster ,(string-append src ".poster.png"))
(controls "controls"))
(p ,(G_ `(a (@ (href ,src) (class "link-subtle"))
"Download video."))))
sxml)))
((tag ('@ attributes ...) body ...)
`(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
((tag body ...)
`(,tag ,@(map change-image-to-video body)))
((? string? str)
str)))
|
