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

Fix bugs in output directories

Browse Source
This commit is contained in:
Eli Barzilay 2010-06-05 14:37:44 -04:00
parent f56532c022
commit 33fb2679ae
1 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -19,14 +19,12 @@
[body #`(lambda () (text #,@xs))]) [body #`(lambda () (text #,@xs))])
#'(layouter id ... x ... body))]))) #'(layouter id ... x ... body))])))
(define (id->file who id sfx dir) (define (id->file who id sfx)
(let* ([f (and id (symbol->string (force id)))] (let ([f (and id (symbol->string (force id)))])
[f (cond [(and f (regexp-match #rx"[.]" f)) f] (cond [(and f (regexp-match #rx"[.]" f)) f]
[(and f sfx) [(and f sfx) (string-append f (regexp-replace #rx"^[.]?" 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 f) f)))
;; 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
@ -37,13 +35,13 @@
(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] #:dir [dir #f]
#:file [file (id->file 'plain id suffix dir)] #:file [file (id->file 'plain id suffix)]
#: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 file (resource (if dir (web-path dir file) file)
(file-writer output (list content (and newline? "\n"))) (file-writer output (list content (and newline? "\n")))
referrer)) referrer))
@ -52,7 +50,7 @@
(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] #:dir [dir #f]
#:file [file (id->file 'page id "html" dir)] #: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 "")]
@ -81,7 +79,9 @@
@(if body-attrs @(if body-attrs
(apply body `(,@body-attrs ,content)) (apply body `(,@body-attrs ,content))
(body content))})) (body content))}))
(define this (resource file (file-writer output-xml page) referrer)) (define this (resource (if dir (web-path dir file) file)
(file-writer output-xml page)
referrer))
this) this)
(provide set-navbar!) (provide set-navbar!)