Clarify a comment for future work; a bunch of new internal definition uses.
original commit: ace5fdf1f3609fff3c583f8ea8fa050a99ac2cf3
This commit is contained in:
Eli Barzilay
commit
27ac7bce2f
|
|
@ -162,15 +162,14 @@
|
|||
;; [*] elements with a cdata/comment body
|
||||
(provide script/inline)
|
||||
(define (script/inline . args)
|
||||
(let-values ([(attrs body) (attributes+body args)])
|
||||
(make-element 'script attrs
|
||||
`("\n"
|
||||
,(set-prefix 0 (apply cdata #:line-prefix "//" body))
|
||||
"\n"))))
|
||||
(define-values [attrs body] (attributes+body args))
|
||||
(make-element
|
||||
'script attrs
|
||||
`("\n" ,(set-prefix 0 (apply cdata #:line-prefix "//" body)) "\n")))
|
||||
(provide style/inline)
|
||||
(define (style/inline . args)
|
||||
(let-values ([(attrs body) (attributes+body args)])
|
||||
(make-element 'style attrs `("\n" ,body "\n"))))
|
||||
(define-values [attrs body] (attributes+body args))
|
||||
(make-element 'style attrs `("\n" ,body "\n")))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Entities
|
||||
|
|
|
|||
|
|
@ -51,17 +51,17 @@
|
|||
;; produces an alist with lists of strings for the keys; the prefix-strings
|
||||
;; are split on "/"s, and the url-strings can be anything at all actually
|
||||
;; (they are put as-is before the path with a "/" between them).
|
||||
(let ([roots (url-roots)])
|
||||
(unless (eq? roots (car cached-roots))
|
||||
(set! cached-roots
|
||||
(cons roots
|
||||
(and (list? roots) (pair? roots)
|
||||
(map (lambda (root)
|
||||
(list* (regexp-match* #rx"[^/]+" (car root))
|
||||
(regexp-replace #rx"/$" (cadr root) "")
|
||||
(cddr root)))
|
||||
roots)))))
|
||||
(cdr cached-roots)))
|
||||
(define roots (url-roots))
|
||||
(unless (eq? roots (car cached-roots))
|
||||
(set! cached-roots
|
||||
(cons roots
|
||||
(and (list? roots) (pair? roots)
|
||||
(map (lambda (root)
|
||||
(list* (regexp-match* #rx"[^/]+" (car root))
|
||||
(regexp-replace #rx"/$" (cadr root) "")
|
||||
(cddr root)))
|
||||
roots)))))
|
||||
(cdr cached-roots))
|
||||
|
||||
;; a utility for relative paths, taking the above `default-file' and
|
||||
;; `url-roots' into consideration.
|
||||
|
|
@ -167,50 +167,50 @@
|
|||
;; can be one of: #f (do nothing), 'delete-file (delete if a file exists, error
|
||||
;; if exists as a directory)
|
||||
(provide resource)
|
||||
(define (resource path renderer referrer #:exists [exists 'delete-file])
|
||||
(define (bad reason) (error 'resource "bad path, ~a: ~e" reason path))
|
||||
(unless (string? path) (bad "must be a string"))
|
||||
(define (resource path0 renderer referrer #:exists [exists 'delete-file])
|
||||
(define (bad reason) (error 'resource "bad path, ~a: ~e" reason path0))
|
||||
(unless (string? path0) (bad "must be a string"))
|
||||
(for ([x (in-list '([#rx"^/" "must be relative"]
|
||||
[#rx"//" "must not have empty elements"]
|
||||
[#rx"(?:^|/)[.][.]?(?:/|$)"
|
||||
"must not contain `.' or `..'"]))])
|
||||
(when (regexp-match? (car x) path) (bad (cadr x))))
|
||||
(let ([path (regexp-replace #rx"(?<=^|/)$" path default-file)])
|
||||
(define-values (dirpathlist filename)
|
||||
(let-values ([(l r) (split-at-right (regexp-split #rx"/" path) 1)])
|
||||
(values l (car r))))
|
||||
(define (render)
|
||||
(let loop ([ps dirpathlist])
|
||||
(if (pair? ps)
|
||||
(begin (unless (directory-exists? (car ps))
|
||||
(if (or (file-exists? (car ps)) (link-exists? (car ps)))
|
||||
(bad "exists as a file/link")
|
||||
(make-directory (car ps))))
|
||||
(parameterize ([current-directory (car ps)])
|
||||
(loop (cdr ps))))
|
||||
(begin (cond [(not exists)] ; do nothing
|
||||
[(or (file-exists? filename) (link-exists? filename))
|
||||
(delete-file filename)]
|
||||
[(directory-exists? filename)
|
||||
(bad "exists as directory")])
|
||||
(parameterize ([rendered-dirpath dirpathlist])
|
||||
(printf " ~a\n" path)
|
||||
(renderer filename))))))
|
||||
(define (url) (relativize filename dirpathlist (rendered-dirpath)))
|
||||
(define absolute-url
|
||||
(delay (let ([url (relativize filename dirpathlist '())])
|
||||
(if (url-roots)
|
||||
url
|
||||
;; we're in local build mode, and insist on an absolute url,
|
||||
;; so construct a `file://' result
|
||||
(list* "file://" (current-directory) url)))))
|
||||
(add-renderer path render)
|
||||
(make-keyword-procedure
|
||||
(lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args))
|
||||
(case-lambda [(x) (if (and (pair? x) (eq? (car x) get-path))
|
||||
(if (cdr x) absolute-url (url))
|
||||
(referrer (url) x))]
|
||||
[args (apply referrer (url) args)]))))
|
||||
(when (regexp-match? (car x) path0) (bad (cadr x))))
|
||||
(define path (regexp-replace #rx"(?<=^|/)$" path0 default-file))
|
||||
(define-values [dirpathlist filename]
|
||||
(let-values ([(l r) (split-at-right (regexp-split #rx"/" path) 1)])
|
||||
(values l (car r))))
|
||||
(define (render)
|
||||
(let loop ([ps dirpathlist])
|
||||
(if (pair? ps)
|
||||
(begin (unless (directory-exists? (car ps))
|
||||
(if (or (file-exists? (car ps)) (link-exists? (car ps)))
|
||||
(bad "exists as a file/link")
|
||||
(make-directory (car ps))))
|
||||
(parameterize ([current-directory (car ps)])
|
||||
(loop (cdr ps))))
|
||||
(begin (cond [(not exists)] ; do nothing
|
||||
[(or (file-exists? filename) (link-exists? filename))
|
||||
(delete-file filename)]
|
||||
[(directory-exists? filename)
|
||||
(bad "exists as directory")])
|
||||
(parameterize ([rendered-dirpath dirpathlist])
|
||||
(printf " ~a\n" path)
|
||||
(renderer filename))))))
|
||||
(define (url) (relativize filename dirpathlist (rendered-dirpath)))
|
||||
(define absolute-url
|
||||
(delay (define url (relativize filename dirpathlist '()))
|
||||
(if (url-roots)
|
||||
url
|
||||
;; we're in local build mode, and insist on an absolute url, so
|
||||
;; construct a `file://' result
|
||||
(list* "file://" (current-directory) url))))
|
||||
(add-renderer path render)
|
||||
(make-keyword-procedure
|
||||
(lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args))
|
||||
(case-lambda [(x) (if (and (pair? x) (eq? (car x) get-path))
|
||||
(if (cdr x) absolute-url (url))
|
||||
(referrer (url) x))]
|
||||
[args (apply referrer (url) args)])))
|
||||
|
||||
;; make it possible to always get the path to a resource
|
||||
(provide get-resource-path)
|
||||
|
|
|
|||
|
|
@ -22,8 +22,8 @@
|
|||
(and (symbol? x)
|
||||
(hash-ref! t x
|
||||
(lambda ()
|
||||
(let ([m (regexp-match #rx"^(.*):$" (symbol->string x))])
|
||||
(and m (string->symbol (cadr m))))))))))
|
||||
(define m (regexp-match #rx"^(.*):$" (symbol->string x)))
|
||||
(and m (string->symbol (cadr m)))))))))
|
||||
|
||||
(provide attribute?)
|
||||
(define attribute? attribute->symbol)
|
||||
|
|
@ -31,11 +31,11 @@
|
|||
(provide attributes+body)
|
||||
(define (attributes+body xs)
|
||||
(let loop ([xs xs] [as '()])
|
||||
(let ([a (and (pair? xs) (attribute->symbol (car xs)))])
|
||||
(cond [(not a) (values (reverse as) xs)]
|
||||
[(null? (cdr xs)) (error 'attriubtes+body
|
||||
"missing attribute value for `~s:'" a)]
|
||||
[else (loop (cddr xs) (cons (cons a (cadr xs)) as))]))))
|
||||
(define a (and (pair? xs) (attribute->symbol (car xs))))
|
||||
(cond [(not a) (values (reverse as) xs)]
|
||||
[(null? (cdr xs)) (error 'attriubtes+body
|
||||
"missing attribute value for `~s:'" a)]
|
||||
[else (loop (cddr xs) (cons (cons a (cadr xs)) as))])))
|
||||
|
||||
;; similar, but keeps the attributes as a list, useful to build new functions
|
||||
;; that accept attributes without knowing about the xml structs.
|
||||
|
|
@ -53,15 +53,15 @@
|
|||
(define (write-string/xml-quote str p [start 0] [end (string-length str)])
|
||||
(let loop ([start start])
|
||||
(when (< start end)
|
||||
(let ([m (regexp-match-positions #rx"[&<>\"]" str start end p)])
|
||||
(when m
|
||||
(write-string (case (string-ref str (caar m))
|
||||
[(#\&) "&"]
|
||||
[(#\<) "<"]
|
||||
[(#\>) ">"]
|
||||
[(#\") """])
|
||||
p)
|
||||
(loop (cdar m)))))))
|
||||
(define m (regexp-match-positions #rx"[&<>\"]" str start end p))
|
||||
(when m
|
||||
(write-string (case (string-ref str (caar m))
|
||||
[(#\&) "&"]
|
||||
[(#\<) "<"]
|
||||
[(#\>) ">"]
|
||||
[(#\") """])
|
||||
p)
|
||||
(loop (cdar m))))))
|
||||
|
||||
(provide xml-writer)
|
||||
(define xml-writer (make-parameter write-string/xml-quote))
|
||||
|
|
@ -87,38 +87,39 @@
|
|||
|
||||
(provide element)
|
||||
(define (element tag . args)
|
||||
(let-values ([(attrs body) (attributes+body args)])
|
||||
(make-element tag attrs body)))
|
||||
(define-values [attrs body] (attributes+body args))
|
||||
(make-element tag attrs body))
|
||||
|
||||
;; similar to element, but will always have a closing tag instead of using the
|
||||
;; short syntax (see also `element->output' below)
|
||||
(provide element/not-empty)
|
||||
(define (element/not-empty tag . args)
|
||||
(let-values ([(attrs body) (attributes+body args)])
|
||||
(make-element tag attrs (if (null? body) '(#f) body))))
|
||||
(define-values [attrs body] (attributes+body args))
|
||||
(make-element tag attrs (if (null? body) '(#f) body)))
|
||||
|
||||
;; convert an element to something output-able
|
||||
(define (element->output e)
|
||||
(let ([tag (element-tag e)]
|
||||
[attrs (element-attrs e)]
|
||||
[body (element-body e)])
|
||||
;; null body means a lone tag, tags that should always have a closer will
|
||||
;; have a '(#f) as their body (see below)
|
||||
(list (with-writer #f "<" tag)
|
||||
(map (lambda (attr)
|
||||
(let ([name (car attr)] [val (cdr attr)])
|
||||
(cond [(not val) #f]
|
||||
;; #t means just mention the attribute
|
||||
[(eq? #t val) (with-writer #f (list " " name))]
|
||||
[else (list (with-writer #f (list " " name "=\""))
|
||||
val
|
||||
(with-writer #f "\""))])))
|
||||
attrs)
|
||||
(if (null? body)
|
||||
(with-writer #f " />")
|
||||
(list (with-writer #f ">")
|
||||
body
|
||||
(with-writer #f "</" tag ">"))))))
|
||||
(define tag (element-tag e))
|
||||
(define attrs (element-attrs e))
|
||||
(define body (element-body e))
|
||||
;; null body means a lone tag, tags that should always have a closer will
|
||||
;; have a '(#f) as their body (see below)
|
||||
(list (with-writer #f "<" tag)
|
||||
(map (lambda (attr)
|
||||
(define name (car attr))
|
||||
(define val (cdr attr))
|
||||
(cond [(not val) #f]
|
||||
;; #t means just mention the attribute
|
||||
[(eq? #t val) (with-writer #f (list " " name))]
|
||||
[else (list (with-writer #f (list " " name "=\""))
|
||||
val
|
||||
(with-writer #f "\""))]))
|
||||
attrs)
|
||||
(if (null? body)
|
||||
(with-writer #f " />")
|
||||
(list (with-writer #f ">")
|
||||
body
|
||||
(with-writer #f "</" tag ">")))))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Literals
|
||||
|
|
@ -134,12 +135,12 @@
|
|||
;; comments and cdata
|
||||
(provide comment)
|
||||
(define (comment #:newlines? [newlines? #f] . body)
|
||||
(let ([newline (and newlines? "\n")])
|
||||
(literal "<!--" newline body newline "-->")))
|
||||
(define newline (and newlines? "\n"))
|
||||
(literal "<!--" newline body newline "-->"))
|
||||
(provide cdata)
|
||||
(define (cdata #:newlines? [newlines? #t] #:line-prefix [pfx #f] . body)
|
||||
(let ([newline (and newlines? "\n")])
|
||||
(literal pfx "<![CDATA[" newline body newline pfx "]]>")))
|
||||
(define newline (and newlines? "\n"))
|
||||
(literal pfx "<![CDATA[" newline body newline pfx "]]>"))
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; Template definition forms
|
||||
|
|
|
|||
|
|
@ -99,12 +99,13 @@
|
|||
(if (eq? i 'cont)
|
||||
0
|
||||
(apply max d (map string-length i)))))
|
||||
(apply map list strs))])
|
||||
(apply map list strs))]
|
||||
[x-length (lambda (col) (if (eq? col 'cont) 0 (length col)))])
|
||||
(for/fold ([indent? #f]) ([row (in-list strs)])
|
||||
(let ([h (apply max 0 (map length row))])
|
||||
(let ([h (apply max 0 (map x-length row))])
|
||||
(let ([row* (for/list ([i (in-range h)])
|
||||
(for/list ([col (in-list row)])
|
||||
(if (i . < . (length col))
|
||||
(if (i . < . (x-length col))
|
||||
(list-ref col i)
|
||||
"")))])
|
||||
(for/fold ([indent? indent?]) ([sub-row (in-list row*)])
|
||||
|
|
@ -116,7 +117,7 @@
|
|||
""
|
||||
col)])
|
||||
(display col)
|
||||
(display (make-string (- w (string-length col)) #\space)))
|
||||
(display (make-string (max 0 (- w (string-length col))) #\space)))
|
||||
#t)
|
||||
(newline)
|
||||
#t)))
|
||||
|
|
|
|||
|
|
@ -182,8 +182,30 @@
|
|||
(set! write old))]
|
||||
#; ; no need for this hack yet
|
||||
[(with-writer-change)
|
||||
;; the function gets the old writer and return a new one
|
||||
;; (useful to sabe the current writer then restore it inside)
|
||||
;; The function gets the old writer and return a new one (useful to
|
||||
;; save the current writer and restore it inside). Could also be
|
||||
;; used to extend a writer, but that shows why a customizable
|
||||
;; writer is a bad choice: instead, it should be a list of
|
||||
;; substitutions that can be extended more conveniently. A simple
|
||||
;; implementation would be to chain functions that do
|
||||
;; substitutions. But that runs into problems when functions want
|
||||
;; to substitute the same thing, and worse: when the output of one
|
||||
;; function would get substituted again by another. Another
|
||||
;; approach would be to join matcher regexps with "|" after
|
||||
;; wrapping each one with parens, then find out which one matched
|
||||
;; by looking at the result and applying its substitution, but the
|
||||
;; problem with that is that is that it forbids having parens in
|
||||
;; the regexps -- this could be fixed by not parenthesizing each
|
||||
;; expression, and instead running the found match against each of
|
||||
;; the input regexps to find the matching one, but that can be very
|
||||
;; inefficient. Yet another issue is that in some cases we might
|
||||
;; *want* the "worse" feature mentioned earlier: for example, when
|
||||
;; we want to do some massaging of the input texts yet still have
|
||||
;; the result encoded for HTML output -- so perhaps the simple
|
||||
;; approach is still better. The only difference from the current
|
||||
;; `with-writer' is using a substituting function, so it can be
|
||||
;; composed with the current one instead of replacing it
|
||||
;; completely.
|
||||
(let ([old write])
|
||||
(set! write ((car c) write))
|
||||
(for-each loop (cdr c))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user