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

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

fix load-page-vars to actually work

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