suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve resource-files code.

Browse Source 
Makes it easy to add more files without more bindings.
This commit is contained in:
Eli Barzilay 2012-06-27 06:10:31 -04:00
parent 9d8b0b3051
commit 06f67b30f3
2 changed files with 32 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/meta/web/common/layout.rkt
View File

@ -178,30 +178,33 @@
(define (html-head-maker style favicon) (define (html-head-maker style favicon)
(define headers (define headers
@list{@meta[name: "generator" content: "Racket"] @list{
@meta[name: "generator" content: "Racket"]
@meta[http-equiv: "Content-Type" content: "text/html; charset=utf-8"] @meta[http-equiv: "Content-Type" content: "text/html; charset=utf-8"]
@favicon @favicon
@style}) @link[rel: "stylesheet" type: "text/css" href: style title: "default"]})
(λ (title* more-headers) (λ (title* more-headers)
(head "\n" (title title*) (head "\n" (title title*)
"\n" headers "\n" headers
(and more-headers (list "\n" more-headers)) (and more-headers (list "\n" more-headers))
"\n"))) "\n")))
(define (make-resources icon logo style) (define (make-resources files)
(let* ([favicon (html-favicon-maker icon)] (define (getfile what) (cadr (assq what files)))
[make-head (html-head-maker style favicon)] (define favicon (html-favicon-maker (getfile 'icon)))
[make-navbar (navbar-maker logo)]) (define make-head (html-head-maker (getfile 'style) favicon))
(define make-navbar (navbar-maker (getfile 'logo)))
(λ (what . more) (λ (what . more)
(apply (case what (apply (case what
[(head) make-head] [(head) make-head]
[(navbar) make-navbar] [(navbar) make-navbar]
[(favicon-headers) favicon] [(favicon-headers) favicon]
[(icon-path) (λ () (url-of icon))] [(icon-path logo-path style-path)
[(logo-path) (λ () (url-of logo))] (λ () (let* ([x (symbol->string what)]
[(style-path) (λ () (url-of style))] [x (regexp-replace #rx"-path$" x "")])
(url-of (getfile (string->symbol x)))))]
[else (error 'resources "internal error")]) [else (error 'resources "internal error")])
more)))) more)))
;; `define+provide-context' should be used in each toplevel directory (= each ;; `define+provide-context' should be used in each toplevel directory (= each
;; site) to have its own resources (and possibly other customizations). ;; site) to have its own resources (and possibly other customizations).
@ -214,10 +217,8 @@
[copyfile-id (datum->syntax stx 'copyfile)] [copyfile-id (datum->syntax stx 'copyfile)]
[symlink-id (datum->syntax stx 'symlink)] [symlink-id (datum->syntax stx 'symlink)]
[resources-id (datum->syntax stx 'the-resources)]) [resources-id (datum->syntax stx 'the-resources)])
(with-syntax ([resources (or resources (with-syntax ([resources (or resources #'(make-resources
#'(make-resources (make-icon dir) (make-resource-files dir)))]
(make-logo dir)
(make-style dir)))]
[provides (if provide? [provides (if provide?
#'(provide page-id plain-id copyfile-id #'(provide page-id plain-id copyfile-id
symlink-id resources-id) symlink-id resources-id)

19
collects/meta/web/common/resources.rkt
View File

@ -10,20 +10,17 @@
(require "utils.rkt") (require "utils.rkt")
(provide make-logo make-icon make-style (provide make-resource-files
navbar-style page-sizes font-family) ; needed for the blog template navbar-style page-sizes font-family) ; needed for the blog template
(define ((make-file-copier file) dir) (define (make-resource-files dir)
(define (copyfile file)
(copyfile-resource (in-here file) (web-path dir file))) (copyfile-resource (in-here file) (web-path dir file)))
(define (writefile file contents)
(define make-logo (make-file-copier "logo.png")) (resource (web-path dir file) (file-writer output (list contents "\n"))))
(define make-icon (make-file-copier "plticon.ico")) `([logo ,(copyfile "logo.png")]
[icon ,(copyfile "plticon.ico")]
(define (make-style dir) [style ,(writefile "plt.css" racket-style)]))
(resource/referrer (web-path dir "plt.css")
(file-writer output (list racket-style "\n"))
(λ (url) (link rel: "stylesheet" type: "text/css"
href: url title: "default"))))
(define page-sizes (define page-sizes
@list{ @list{