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

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

@ -10,20 +10,17 @@
(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
(define ((make-file-copier file) dir)
(define (make-resource-files dir)
(define (copyfile file)
(copyfile-resource (in-here file) (web-path dir file)))
(define make-logo (make-file-copier "logo.png"))
(define make-icon (make-file-copier "plticon.ico"))
(define (make-style dir)
(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 (writefile file contents)
(resource (web-path dir file) (file-writer output (list contents "\n"))))
`([logo ,(copyfile "logo.png")]
[icon ,(copyfile "plticon.ico")]
[style ,(writefile "plt.css" racket-style)]))
(define page-sizes
@list{