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

Factor our the common path computation.

Browse Source
This commit is contained in:
Eli Barzilay 2010-06-16 01:43:34 -04:00
parent 00bca21339
commit 1cce6c1f88
1 changed files with 15 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -19,12 +19,16 @@
[body #`(lambda () (text #,@xs))]) [body #`(lambda () (text #,@xs))])
#'(layouter id ... x ... body))]))) #'(layouter id ... x ... body))])))
(define (id->file who id sfx) (define (get-path who id file sfx dir)
(define file*
(or file
(let ([f (and id (symbol->string (force id)))]) (let ([f (and id (symbol->string (force id)))])
(cond [(and f (regexp-match #rx"[.]" f)) f] (cond [(and f (regexp-match #rx"[.]" f)) f]
[(and f sfx) (string-append f (regexp-replace #rx"^[.]?" sfx "."))] [(and f sfx)
(string-append f (regexp-replace #rx"^[.]?" sfx "."))]
[else (error who "missing `#:file', or `#:id'~a" [else (error who "missing `#:file', or `#:id'~a"
(if sfx "" " and `#:suffix'"))]))) (if sfx "" " and `#:suffix'"))]))))
(if dir (web-path dir file*) file*))
;; The following are not intended for direct use, see ;; The following are not intended for direct use, see
;; `define+provide-context' below (it could be used with #f for the ;; `define+provide-context' below (it could be used with #f for the
@ -34,23 +38,21 @@
;; for plain text files ;; for plain text files
(define-syntax (plain stx) (define-syntax (plain stx)
(syntax-case stx () [(_ . xs) (process-contents 'plain #'plain* stx #'xs)])) (syntax-case stx () [(_ . xs) (process-contents 'plain #'plain* stx #'xs)]))
(define (plain* #:id [id #f] #:suffix [suffix #f] #:dir [dir #f] (define (plain* #:id [id #f] #:suffix [suffix #f]
#:file [file (id->file 'plain id suffix)] #:dir [dir #f] #:file [file #f]
#:referrer #:referrer
[referrer (lambda (url) [referrer (lambda (url)
(error 'plain "no referrer for ~e" file))] (error 'plain "no referrer for ~e" file))]
#:newline [newline? #t] #:newline [newline? #t]
content) content)
(resource (if dir (web-path dir file) file) (resource (get-path 'plain id file suffix dir)
(file-writer output (list content (and newline? "\n"))) (file-writer output (list content (and newline? "\n")))
referrer)) referrer))
;; page layout function ;; page layout function
(define-syntax (page stx) (define-syntax (page stx)
(syntax-case stx () [(_ . xs) (process-contents 'page #'page* stx #'xs)])) (syntax-case stx () [(_ . xs) (process-contents 'page #'page* stx #'xs)]))
(define (page* #:id [id #f] (define (page* #:id [id #f] #:dir [dir #f] #:file [file #f]
#:dir [dir #f]
#:file [file (id->file 'page id "html")]
#:title [label (if id #:title [label (if id
(let* ([id (->string (force id))] (let* ([id (->string (force id))]
[id (regexp-replace #rx"^.*/" id "")] [id (regexp-replace #rx"^.*/" id "")]
@ -79,7 +81,7 @@
@(if body-attrs @(if body-attrs
(apply body `(,@body-attrs ,content)) (apply body `(,@body-attrs ,content))
(body content))})) (body content))}))
(define this (resource (if dir (web-path dir file) file) (define this (resource (get-path 'plain id file "html" dir)
(file-writer output-xml page) (file-writer output-xml page)
referrer)) referrer))
this) this)