diff --git a/collects/scribble/html/html.rkt b/collects/scribble/html/html.rkt index 1f8fa1a6..56978eda 100644 --- a/collects/scribble/html/html.rkt +++ b/collects/scribble/html/html.rkt @@ -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 diff --git a/collects/scribble/html/resource.rkt b/collects/scribble/html/resource.rkt index 1cd83ec7..dec2d404 100644 --- a/collects/scribble/html/resource.rkt +++ b/collects/scribble/html/resource.rkt @@ -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) diff --git a/collects/scribble/html/xml.rkt b/collects/scribble/html/xml.rkt index d5e0a03a..f9df7dc2 100644 --- a/collects/scribble/html/xml.rkt +++ b/collects/scribble/html/xml.rkt @@ -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 "")))))) + (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 ""))))) ;; ---------------------------------------------------------------------------- ;; Literals @@ -134,12 +135,12 @@ ;; comments and cdata (provide comment) (define (comment #:newlines? [newlines? #f] . body) - (let ([newline (and newlines? "\n")]) - (literal ""))) + (define newline (and newlines? "\n")) + (literal "")) (provide cdata) (define (cdata #:newlines? [newlines? #t] #:line-prefix [pfx #f] . body) - (let ([newline (and newlines? "\n")]) - (literal pfx ""))) + (define newline (and newlines? "\n")) + (literal pfx "")) ;; ---------------------------------------------------------------------------- ;; Template definition forms diff --git a/collects/scribble/text-render.rkt b/collects/scribble/text-render.rkt index 7cd34bf6..472a550e 100644 --- a/collects/scribble/text-render.rkt +++ b/collects/scribble/text-render.rkt @@ -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))) diff --git a/collects/scribble/text/output.rkt b/collects/scribble/text/output.rkt index 26ee1099..740eea84 100644 --- a/collects/scribble/text/output.rkt +++ b/collects/scribble/text/output.rkt @@ -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))