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.
123 lines
3.3 KiB
Scheme
123 lines
3.3 KiB
Scheme
(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 js
|
|
|
|
; core functions
|
|
add-page! delete-page! add-css! delete-css!
|
|
add-file-resource! delete-file-resource!
|
|
compile-site
|
|
)
|
|
|
|
(import chicken scheme files srfi-1 extras ports irregex)
|
|
(use sxml-transforms srfi-69 scss srfi-13 lowdown doctype posix)
|
|
|
|
(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 ""))
|
|
(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 (js path)
|
|
`(script (@ (type "text/javascript") (src ,(++ (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)
|
|
(set! *file-resources* (cons path *file-resources*)))
|
|
|
|
(define (delete-file-resource! path)
|
|
(set! *file-resources* (remove (lambda (p) (equal? p path)) *file-resources*)))
|
|
|
|
(define (create-dirs path)
|
|
(create-directory (pathname-directory path) #t))
|
|
|
|
(define (output-pages)
|
|
(hash-table-for-each
|
|
*pages*
|
|
(lambda (k v)
|
|
(let ((p (++ (out-dir) "/" k)))
|
|
(create-dirs p)
|
|
(with-output-to-file p
|
|
(lambda () (print (doctype) (sxml->html v))))))))
|
|
|
|
(define (output-stylesheets)
|
|
(hash-table-for-each
|
|
*stylesheets*
|
|
(lambda (k v)
|
|
(let ((p (++ (out-dir) "/" k)))
|
|
(create-dirs p)
|
|
(with-output-to-file p
|
|
(lambda () (scss->css v)))))))
|
|
|
|
(define (copy-file-resources)
|
|
(for-each
|
|
(lambda (p)
|
|
(let ((path-out (++ (out-dir) "/" p)))
|
|
(create-dirs path-out)
|
|
(file-copy (++ (res-dir) "/" p) path-out)))
|
|
*file-resources*))
|
|
|
|
(define (compile-site #!key (clean #t))
|
|
(when clean (and (directory? (out-dir)) (delete-directory (out-dir) #t)))
|
|
(output-pages)
|
|
(output-stylesheets)
|
|
(copy-file-resources))
|
|
|
|
)
|