You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
109 lines
2.8 KiB
Scheme
109 lines
2.8 KiB
Scheme
11 years ago
|
(module alley-cat
|
||
|
|
(
|
||
|
|
; params
|
||
|
|
src-dir out-dir res-dir link-root doctype
|
||
|
|
|
||
|
|
; generic functions
|
||
|
|
sxml->html
|
||
|
|
|
||
|
|
; helper functions
|
||
|
|
markdown-file->sxml link link-list css
|
||
|
|
|
||
|
|
; core functions
|
||
|
|
add-page! delete-page! add-css! delete-css!
|
||
|
|
add-file-resource! delete-file-resource!
|
||
|
|
compile
|
||
|
|
)
|
||
|
|
|
||
|
|
(import chicken scheme files srfi-1 extras ports)
|
||
|
|
(use sxml-transforms srfi-69 scss srfi-13 lowdown doctype)
|
||
|
|
|
||
|
|
(define *pages* (make-hash-table))
|
||
|
|
(define *stylesheets* (make-hash-table))
|
||
|
|
(define *file-resources* '())
|
||
|
|
|
||
|
|
(define src-dir (make-parameter "src"))
|
||
|
|
(define out-dir (make-parameter "out"))
|
||
|
|
(define res-dir (make-parameter "res"))
|
||
|
|
(define link-root (make-parameter "/home"))
|
||
|
|
(define doctype (make-parameter doctype-html))
|
||
|
|
|
||
|
|
(define ++ string-append)
|
||
|
|
|
||
|
|
(define (map-match func list)
|
||
|
|
(if (null? list)
|
||
|
|
'()
|
||
|
|
(cons (apply func (car list))
|
||
|
|
(map-match func (cdr list)))))
|
||
|
|
|
||
|
|
; take from awful: Copyright (c) 2010-2013, Mario Domenech Goulart; BSD
|
||
|
|
(define sxml->html
|
||
|
|
(let ((rules `((literal *preorder* . ,(lambda (t b) b))
|
||
|
|
. ,universal-conversion-rules*)))
|
||
|
|
(lambda (sxml)
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(SRV:send-reply (pre-post-order* sxml rules)))))))
|
||
|
|
|
||
|
|
(define (link path text)
|
||
|
|
`(a (@ (href ,(if (and (> (string-length path) 0)
|
||
|
|
(string=? "/" (string-take path 1)))
|
||
|
|
(++ (link-root) path)
|
||
|
|
path))) ,text))
|
||
|
|
|
||
|
|
(define (link-list list #!key (ul@ '(@ ())) (li@ '(@ ())))
|
||
|
|
`(ul ,ul@
|
||
|
|
,(map-match (lambda (path text)
|
||
|
|
`(li ,li@ ,(link path text)))
|
||
|
|
list)))
|
||
|
|
|
||
|
|
(define (markdown-file->sxml file-path)
|
||
|
|
(markdown->sxml (with-input-from-file file-path (lambda () (read-string)))))
|
||
|
|
|
||
|
|
(define (css path)
|
||
|
|
`(link (@ (rel "stylesheet") (href ,(++ (link-root) path)))))
|
||
|
|
|
||
|
|
(define (add-page! path body)
|
||
|
|
(hash-table-set! *pages* path body))
|
||
|
|
|
||
|
|
(define (delete-page! path)
|
||
|
|
(hash-table-delete! *pages* path))
|
||
|
|
|
||
|
|
(define (add-css! path body)
|
||
|
|
(hash-table-set! *stylesheets* path body))
|
||
|
|
|
||
|
|
(define (delete-css! path)
|
||
|
|
(hash-table-delete! *stylesheets* path))
|
||
|
|
|
||
|
|
(define (add-file-resource! path)
|
||
|
|
(cons path *file-resources*))
|
||
|
|
|
||
|
|
(define (delete-file-resource! path)
|
||
|
|
(remove (lambda (p) (equal? p path)) *file-resources*))
|
||
|
|
|
||
|
|
(define (output-pages)
|
||
|
|
(hash-table-for-each
|
||
|
|
*pages*
|
||
|
|
(lambda (k v)
|
||
|
|
(with-output-to-file (++ (out-dir) "/" k)
|
||
|
|
(lambda () (print (doctype) (sxml->html v)))))))
|
||
|
|
|
||
|
|
(define (output-stylesheets)
|
||
|
|
(hash-table-for-each
|
||
|
|
*stylesheets*
|
||
|
|
(lambda (k v)
|
||
|
|
(with-output-to-file (++ (out-dir) "/" k)
|
||
|
|
(lambda () (scss->css v))))))
|
||
|
|
|
||
|
|
(define (copy-file-resources)
|
||
|
|
(for-each (lambda (p)
|
||
|
|
(file-copy (++ (res-dir) "/" p) (++ (out-dir) "/" p)))
|
||
|
|
*file-resources*))
|
||
|
|
|
||
|
|
(define (compile)
|
||
|
|
(output-pages)
|
||
|
|
(output-stylesheets)
|
||
|
|
(copy-file-resources))
|
||
|
|
|
||
|
|
)
|