-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathwww.scm
179 lines (161 loc) · 6.08 KB
/
www.scm
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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
;; Write HTML files into the `www` subdirectory.
;;
;; You need Chicken 5 and
;; `chicken-install colorize html-parser lowdown r7rs srfi-1 srfi-13 srfi-132 ssax`
(import (scheme base)
(scheme file)
(scheme read)
(scheme write)
(srfi 1)
(srfi 13)
(srfi 132)
(only (chicken file) copy-file create-directory)
(sxml-transforms)
(lowdown) ; Markdown->SXML parser.
(www-lowdown-colorize))
(enable-www-lowdown-colorize!)
(define licenses
'("CC0-1.0"
"ISC"
"MIT"
"BSD-3-Clause"
"LGPL-2.1-or-later"))
(define (disp . xs) (for-each display xs) (newline))
(define (edisp . xs)
(parameterize ((current-output-port (current-error-port)))
(apply disp xs)
(flush-output-port)))
(define (write-html-file html-filename title description body)
(edisp "Writing " html-filename)
(with-output-to-file html-filename
(lambda ()
(write-string "<!DOCTYPE html>")
(SXML->HTML
`(html (@ (lang "en"))
(head
(meta (@ charset "UTF-8"))
(title ,title)
(link (@ (rel "stylesheet") (href "/schemeorg.css")))
(link (@ (rel "stylesheet") (href "/colorize.css")))
(meta (@ (name "viewport")
(content "width=device-width, initial-scale=1")))
(meta (@ (name "description")
(content ,description))))
(body ,@body))))))
(define (page-title-from-sxml tags)
(let rec ((tags tags))
(cond ((not (and (pair? tags) (pair? (car tags))))
;; (error "Markdown page has no title")
#f)
((eqv? 'h1 (car (car tags)))
(apply string-append (cadr (car tags))))
(else (rec (cdr tags))))))
(define-record-type recipe
(make-recipe stem title sxml)
recipe?
(stem recipe-stem)
(title recipe-title)
(sxml recipe-sxml))
(define (recipe<? a b) (string-ci<? (recipe-title a) (recipe-title b)))
(define (read-recipe-with-stem stem)
(let ((md-filename (string-append "recipes" "/" stem ".md")))
;;(edisp "Reading " md-filename)
(let* ((sxml (call-with-port (open-input-file md-filename)
markdown->sxml))
(title (or (page-title-from-sxml sxml) stem)))
(make-recipe stem title sxml))))
(define groups-template (with-input-from-file "www-index.scm" read))
(define group-title car)
(define group-recipes cdr)
(define groups
(map (lambda (group)
(cons (group-title group)
(list-sort recipe<?
(map read-recipe-with-stem
(group-recipes group)))))
groups-template))
(define (about-section subdomain user/repo)
`(section
(@ (id "schemeorg-contributing"))
(h2 "About " ,subdomain ".scheme.org")
(div (@ (class "round-box gray-box"))
(p (kbd ,subdomain ".scheme.org")
" is a community subdomain of "
(kbd "scheme.org"))
(ul
(li "Source code: "
(a (@ (href ,(string-append
"https://github.com/"
user/repo)))
(kbd (@ (class "github-repo"))
,user/repo))
" repository on GitHub.")
(li "Discussion: "
(code (@ (class "mailing-list"))
"schemeorg")
" mailing list "
"(" (a (@ (href
"https://srfi-email.schemers.org/schemeorg/"))
"archives")
", " (a (@ (href
,(string-append
"https://srfi.schemers.org/"
"srfi-list-subscribe.html#schemeorg")))
"subscribe")
").")))))
(define (write-front-page html-filename)
(write-html-file
html-filename
"The Scheme Cookbook"
(string-append "Scheme is a minimalist dialect of the Lisp family "
"of programming languages.")
`((h1 (@ (id "logo")) "Scheme Cookbook")
(h2 "License")
(p "The code in the cookbook is released under several common"
" licenses simultaneously. The user is free to pick any one"
" of them. The aim is to make it easy"
" to copy code into existing projects without having"
" to add a new license notice to cover the cookbook material.")
(p "The licenses are: "
,@(cdr (append-map (lambda (license)
`(", "
(a (@ (href ,(string-append
"licenses/" license ".txt")))
(kbd ,license))))
licenses)))
(h2 "Recipes")
,@(map (lambda (group)
`(section
(h3 ,(group-title group))
(ul ,@(map (lambda (recipe)
(let ((href (string-append (recipe-stem recipe)
"/")))
`(li (a (@ (href ,href))
,(recipe-title recipe)))))
(group-recipes group)))))
groups)
,(about-section "cookbook" "schemedoc/cookbook")
(p (a (@ (href "https://www.scheme.org/"))
"Back to Scheme.org")))))
(define (write-recipe-page recipe)
(let ((recipe-dir (string-append "www" "/" (recipe-stem recipe))))
(create-directory recipe-dir)
(write-html-file
(string-append recipe-dir "/" "index.html")
(recipe-title recipe)
"A recipe in the Scheme Cookbook."
`(,@(recipe-sxml recipe)
(hr)
(p (a (@ (href "/")) "Back to the Scheme Cookbook"))))))
(define (main)
(create-directory "www")
(create-directory "www/licenses")
(for-each (lambda (license)
(copy-file (string-append "LICENSES/" license ".txt")
(string-append "www/licenses/" license ".txt")
#t))
licenses)
(write-front-page "www/index.html")
(for-each write-recipe-page (append-map group-recipes groups))
0)
(main)