source: project/release/4/hyde/hyde.scm @ 18147

Last change on this file since 18147 was 18147, checked in by Moritz Heidkamp, 9 years ago

generate correct target paths during compilation preparation

File size: 7.3 KB
Line 
1(module hyde
2
3(load-hyde-file
4 initialize-site
5 generate-page
6 serve
7 source-dir
8 output-dir
9 layouts-dir
10 default-layout
11 clean-before-build
12 excluded-paths
13 default-extension
14 default-page-vars
15 page-eval-env
16 translators
17 compile-pages)
18
19(import chicken scheme files data-structures extras srfi-1 ports srfi-13)
20(require-extension regex)
21(import irregex)
22
23(use posix
24     (rename filepath (filepath:make-relative pathname-relative-from))
25     environments
26     sxml-transforms
27     sxml-fu
28     sxml-shortcuts
29     doctype
30     matchable
31     scss
32     scss-plus
33     spiffy)
34
35
36(define source-dir (make-parameter "src"))
37(define output-dir (make-parameter "out"))
38(define layouts-dir (make-parameter "layouts"))
39(define default-layout (make-parameter '("default.sxml")))
40(define clean-before-build (make-parameter #t))
41(define excluded-paths (make-parameter (list (irregex '(seq "~" eos)))))
42(define default-extension (make-parameter "html"))
43(define default-page-vars (make-parameter '()))
44
45(define translators (make-parameter '()))
46(define page-vars (make-parameter '()))
47(define pages (make-parameter '()))
48(define page-eval-env (make-parameter (environment-copy (interaction-environment))))
49(environment-set! (page-eval-env) '$ (lambda (name)
50                                       (alist-ref name (page-vars))))
51
52(define sxml-conversion-rules 
53  `((inject *preorder* . ,(project 1))
54    ,@doctype-rules
55    ,@universal-conversion-rules))
56
57(define (print-error error)
58  (with-output-to-port (current-error-port)
59    (cut print error)))
60
61(define (die error exit-code)
62  (print-error error)
63  (exit exit-code))
64
65(define (load-hyde-file)
66  (if (file-exists? "hyde.scm")
67      (load "hyde.scm")
68      (die "no hyde.scm found" 1)))
69
70(define (create-directory-verbose name)
71  (print "creating " name)
72  (create-directory name #t))
73
74(define (initialize-site)
75  (unless (null? (directory))
76    (die "unable to initialize site, directory is not empty" 1))
77 
78  (create-directory-verbose (layouts-dir))
79  (create-directory-verbose (source-dir))
80  (create-directory-verbose (output-dir))
81
82  (print "creating hyde.scm")
83  (with-output-to-file "hyde.scm" (cut write '(use hyde))))
84
85(define (generate-page ext title)
86  (let* ((title (string-intersperse title))
87         (path  (string-downcase title))
88         (path  (irregex-replace/all '(or (submatch (+ space)) (submatch (+ (~ alpha)))) path "-" ""))
89         (path  (string-trim-both path #\-))
90         (path  (make-pathname (source-dir) path ext)))
91    (with-output-to-file path (cut write `((title . ,title))))
92    (print path)))
93
94(define (serve)
95  (root-path (output-dir))
96  (vhost-map `((".*" . ,(lambda (continue)
97                          (compile-pages)
98                          (newline)
99                          (continue)))))
100
101  (print (format "spiffy serving hyde on port ~A" (server-port)))
102  (start-server))
103
104(define (cmd name . args)
105  (receive (_ exited-normally status)
106    (process-wait (process-run name args))
107    (unless (and exited-normally (zero? status))
108      (error (format "error executing ~A ~A" name (string-intersperse args))))))
109
110(define (make-output-path path #!optional page-vars)
111  (let ((output-file (make-pathname (output-dir) (pathname-relative-from (source-dir) path))))
112    (if page-vars
113        (pathname-replace-extension output-file (->string (or (alist-ref 'ext page-vars) (default-extension))))
114        output-file)))
115
116(define (call-with-returning value proc)
117  (proc value)
118  value)
119
120(define (wrap-with-layout layout contents)
121  (with-input-from-source-file layout
122    (lambda (meta)
123      (let ((translator (translator-for layout)))
124        (if translator
125            (begin
126              (page-vars (append meta (page-vars)))
127              (environment-set! (page-eval-env) 'contents contents)
128              (environment-set! (page-eval-env) 'pages (pages))
129              (translator))
130            (error (format "unknown layout format: ~A" layout)))))))
131
132(define (wrap-with-layouts contents)
133  (let* ((layouts (or (alist-ref 'layout (page-vars)) (default-layout)))
134         (contents (fold (cut wrap-with-layout <> <>)
135                         contents
136                         (map (cut make-pathname (layouts-dir) <>) layouts))))
137    (print contents)))
138
139(define (with-input-from-source-file source-file proc)
140  (with-input-from-file source-file
141    (lambda ()
142      (proc (read)))))
143
144(define (write-to-target-file-for source-file contents)
145  (let* ((target-file (make-output-path source-file (page-vars))))
146
147    (with-output-to-file target-file 
148      (lambda ()
149        (wrap-with-layouts contents)))
150
151    target-file))
152
153(define (compile-by-extension file #!optional (vars (default-page-vars)) (env (environment-copy (page-eval-env))))
154  (let ((translator (translator-for file)))
155    (if translator
156        (with-input-from-source-file file 
157          (lambda (meta)
158            (parameterize ((page-vars (append meta vars))
159                           (page-eval-env env))
160              (write-to-target-file-for file (translator)))))
161        (call-with-returning (make-output-path file)
162          (cut file-copy file <> #t)))))
163
164(define (translator-for file)
165  (and-let* ((ext (pathname-extension file))
166             (translate (alist-ref ext (translators) string=?)))
167    (lambda () 
168      (with-output-to-string translate))))
169
170(define (load-page-vars file)
171  (let ((page-vars (with-input-from-file file read)))
172   (pages (cons (list (pathname-relative-from (source-dir) file)
173                      (make-pathname "/" (pathname-relative-from (output-dir) (make-output-path file page-vars)))
174                      page-vars) (pages)))))
175
176(define (compile-page source-file)
177  (display "* ")
178  (display (pathname-relative-from (source-dir) source-file))
179  (let ((target-file (compile-by-extension source-file)))
180    (print " -> " (pathname-relative-from (output-dir) target-file))))
181
182(define (exclude-file? file)
183  (not (any (cut irregex-search <> file) (excluded-paths))))
184
185(define (compile-pages)
186  (when (clean-before-build)
187    (print "cleaning output directory")
188    (cmd "rm" "-rf" (output-dir))
189    (create-directory (output-dir)))
190
191  (parameterize ((pages '()))
192    (print "preparing compilation")
193    (find-files (source-dir)
194                exclude-file?
195                (lambda (path _)
196                  (unless (directory? path)
197                    (load-page-vars path))))
198
199    (print "compiling pages")
200    (find-files (source-dir)
201                exclude-file?
202                (lambda (path _) 
203                  (if (directory? path)
204                      (create-directory (make-output-path path))
205                      (compile-page path))))))
206
207(define (read-sexps)
208  (let loop ((s (read)))
209    (if (eof-object? s) '() (cons s (loop (read))))))
210
211(define (read/write-lines)
212  (let loop ((line (read-line)))
213    (unless (eof-object? line)
214      (print line)
215      (loop (read-line)))))
216
217(define (translate/sxml)
218  (output-xml
219   (map (lambda (e) (eval e (page-eval-env))) (read-sexps))
220   (list shortcut-rules sxml-conversion-rules)))
221
222(translators (alist-cons "sxml" translate/sxml (translators)))
223
224(define (translate/markdown)
225  (receive (in out pid err)
226    (process* "markdown")
227    (with-output-to-port out read/write-lines)
228    (close-output-port out)
229    (with-input-from-port in read/write-lines)
230    (close-input-port in)
231    (close-input-port err)))
232
233(translators (alist-cons "md" translate/markdown (translators)))
234
235(define (translate/scss)
236  (page-vars (append (page-vars) '((ext . css)
237                                   (layout))))
238
239  (let loop ((sexp (read)))
240    (unless (eof-object? sexp)
241      (let ((scss (eval sexp (page-eval-env))))
242        (print (match scss
243                 (('css  . ...) (scss->css scss))
244                 (('css+ . ...) (scss-plus->css scss))
245                 (...          (scss-plus->css (cons 'css+ scss))))))
246      (loop (read)))))
247
248(translators (alist-cons "scss" translate/scss (translators)))
249
250)
251
Note: See TracBrowser for help on using the repository browser.