From 39ccb05def8bf1745ffc0a22f8ef426e889826d1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 4 Jun 2010 14:11:19 -0400 Subject: [PATCH] Generic (X)HTML generation framework (Will later move into the scribble collection.) original commit: 9a0b78d9ad35d7363d0aedd8669fb025c55d663d --- collects/meta/web/html.rkt | 4 + collects/meta/web/html/html.rkt | 462 ++++++++++++++++++++++++++++ collects/meta/web/html/main.rkt | 21 ++ collects/meta/web/html/resource.rkt | 198 ++++++++++++ collects/meta/web/html/xml.rkt | 147 +++++++++ 5 files changed, 832 insertions(+) create mode 100644 collects/meta/web/html.rkt create mode 100644 collects/meta/web/html/html.rkt create mode 100644 collects/meta/web/html/main.rkt create mode 100644 collects/meta/web/html/resource.rkt create mode 100644 collects/meta/web/html/xml.rkt diff --git a/collects/meta/web/html.rkt b/collects/meta/web/html.rkt new file mode 100644 index 00000000..7d69f7c0 --- /dev/null +++ b/collects/meta/web/html.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require "html/main.rkt") +(provide (all-from-out "html/main.rkt")) diff --git a/collects/meta/web/html/html.rkt b/collects/meta/web/html/html.rkt new file mode 100644 index 00000000..ffe89407 --- /dev/null +++ b/collects/meta/web/html/html.rkt @@ -0,0 +1,462 @@ +#lang racket/base + +;; (X)HTML elements etc. + +(require "xml.rkt" scribble/text) + +;; ---------------------------------------------------------------------------- +;; Xhtml toplevel + +;; creation of xhtml files requires some extra stuff +(define xhtml-prefix + (literal + (string-append + "\n" + "\n"))) +(provide xhtml) +(define (xhtml . body) + (list xhtml-prefix + (apply html 'xmlns: "http://www.w3.org/1999/xhtml" body) + "\n")) + +;; ---------------------------------------------------------------------------- +;; Elements + +;; For complete reference: http://www.w3.org/TR/html/dtds.html +;; (See also http://www.w3schools.com/tags/) + +;; The dtds, in increasing size: +;; http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd +;; http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd +;; http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd + +;; These are all entities, taked from the DTDs. The ones marked with "[*]" are +;; defined later, since they need a different definition. +(define/provide-elements/not-empty + ;; ========== Document Structure + html + ;; ========== Document Head + head + ;; The title element is not considered part of the flow of text. + ;; It should be displayed, for example as the page header or + ;; window title. Exactly one title is required per document. + title + ;; base ; document base URI, can be empty [*] + ;; meta ; generic metainformation, can be empty [*] + ;; link ; relationship values, can be empty [*] + style ; style info, which may include CDATA sections + script ; script statements, which may include CDATA sections + noscript ; alternate content container for non script-based rendering + ;; ========== Frames + frameset ; only one noframes element permitted per document + frame ; tiled window within frameset + iframe ; inline subwindow + noframes ; alternate content container for non frame-based rendering + ;; ========== Document Body + body + div ; generic language/style container + ;; ========== Paragraphs + p + ;; ========== Headings + h1 + h2 + h3 + h4 + h5 + h6 + ;; ========== Lists + ul ; Unordered list + ol ; Ordered (numbered) list + menu ; single column list (DEPRECATED) + dir ; multiple column list (DEPRECATED) + li ; list item + dl ; definition lists - dt for term, dd for its definition + dt + dd + ;; ========== Address + address ; information on author + ;; ========== Horizontal Rule + ;; hr ; horizontal rule can be empty [*] + ;; ========== Preformatted Text + pre + ;; ========== Block-like Quotes + blockquote + ;; ========== Text alignment + center ; center content + ;; ========== Inserted/Deleted Text + ins + del + ;; ========== The Anchor Element + a ; content is inline; except that anchors shouldn't be nested + ;; ========== Inline Elements + span ; generic language/style container + bdo ; I18N BiDi over-ride + ;; br ; forced line break, can be empty [*] + em ; emphasis + strong ; strong emphasis + dfn ; definitional + code ; program code + samp ; sample + kbd ; something user would type + var ; variable + cite ; citation + abbr ; abbreviation + acronym ; acronym + q ; inlined quote + sub ; subscript + sup ; superscript + tt ; fixed pitch font + i ; italic font + b ; bold font + big ; bigger font + small ; smaller font + u ; underline + s ; strike-through + strike ; strike-through + ;; basefont ; base font size, can be empty [*] + font ; local change to font + ;; ========== Object + object ; embeded objects + ;; param ; parameters for objects, can also specify as attrs, can be empty [*] + applet ; Java applet + ;; ========== Images + ;; To avoid accessibility problems for people who aren't + ;; able to see the image, you should provide a text + ;; description using the alt and longdesc attributes. + ;; In addition, avoid the use of server-side image maps. + ;; img ; can be empty [*] + ;; ========== Client-side image maps + ;; map ; collides with scheme, but not really useful + ;; area ; can be empty [*] + ;; ========== Forms + form ; forms shouldn't be nested + label ; text that belongs to a form control + ;; input ; form control, can be empty [*] + select ; option selector + optgroup ; option group + option ; selectable choice + textarea ; multi-line text field + fieldset ; group form fields + legend ; fieldset label (one per fieldset) + button ; push button + ;; isindex ; single-line text input control (DEPRECATED), can be empty [*] + ;; ========== Tables + table ; holds caption?, (col*|colgroup*), thead?, tfoot?, (tbody+|tr+) + caption ; caption text + thead ; header part, holds tr + tfoot ; footer part, holds tr + tbody ; body part, holds tr + colgroup ; column group, olds col + ;; col ; column info, has only attributes, can be empty [*] + tr ; holds th or td + th ; header cell + td ; table cell + ) + +;; [*] empty elements, these are listed with an `EMPTY' content in +;; http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd +(define/provide-elements/empty + base meta link hr br basefont param img area input isindex col) + +;; [*] 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")))) +(provide style/inline) +(define (style/inline . args) + (let-values ([(attrs body) (attributes+body args)]) + (make-element 'style attrs + `("\n" ,(apply comment #:newlines? #t body) "\n")))) + +;; ---------------------------------------------------------------------------- +;; Entities + +;; The three dtds that define the set of entities are at: +;; http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent +;; http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent +;; http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent + +(define/provide-entities + nbsp ndash mdash bull middot sdot lsquo rsquo sbquo ldquo rdquo bdquo + lang rang dagger Dagger plusmn deg) + +#; ; the complete list +(define/provide-entities + ;; 24.2 Character entity references for ISO 8859-1 characters + nbsp ;00A0 no-break space = non-breaking space + iexcl ;00A1 inverted exclamation mark + cent ;00A2 cent sign + pound ;00A3 pound sign + curren ;00A4 currency sign + yen ;00A5 yen sign = yuan sign + brvbar ;00A6 broken bar = broken vertical bar + sect ;00A7 section sign + uml ;00A8 diaeresis = spacing diaeresis + copy ;00A9 copyright sign + ordf ;00AA feminine ordinal indicator + laquo ;00AB left-pointing double angle quotation mark = left pointing guillemet + not ;00AC not sign + shy ;00AD soft hyphen = discretionary hyphen + reg ;00AE registered sign = registered trade mark sign + macr ;00AF macron = spacing macron = overline = APL overbar + deg ;00B0 degree sign + plusmn ;00B1 plus-minus sign = plus-or-minus sign + sup2 ;00B2 superscript two = superscript digit two = squared + sup3 ;00B3 superscript three = superscript digit three = cubed + acute ;00B4 acute accent = spacing acute + micro ;00B5 micro sign + para ;00B6 pilcrow sign = paragraph sign + middot ;00B7 middle dot = Georgian comma = Greek middle dot + cedil ;00B8 cedilla = spacing cedilla + sup1 ;00B9 superscript one = superscript digit one + ordm ;00BA masculine ordinal indicator + raquo ;00BB right-pointing double angle quotation mark = right pointing guillemet + frac14 ;00BC vulgar fraction one quarter = fraction one quarter + frac12 ;00BD vulgar fraction one half = fraction one half + frac34 ;00BE vulgar fraction three quarters = fraction three quarters + iquest ;00BF inverted question mark = turned question mark + Agrave ;00C0 latin capital letter A with grave = latin capital letter A grave + Aacute ;00C1 latin capital letter A with acute + Acirc ;00C2 latin capital letter A with circumflex + Atilde ;00C3 latin capital letter A with tilde + Auml ;00C4 latin capital letter A with diaeresis + Aring ;00C5 latin capital letter A with ring above = latin capital letter A ring + AElig ;00C6 latin capital letter AE = latin capital ligature AE + Ccedil ;00C7 latin capital letter C with cedilla + Egrave ;00C8 latin capital letter E with grave + Eacute ;00C9 latin capital letter E with acute + Ecirc ;00CA latin capital letter E with circumflex + Euml ;00CB latin capital letter E with diaeresis + Igrave ;00CC latin capital letter I with grave + Iacute ;00CD latin capital letter I with acute + Icirc ;00CE latin capital letter I with circumflex + Iuml ;00CF latin capital letter I with diaeresis + ETH ;00D0 latin capital letter ETH + Ntilde ;00D1 latin capital letter N with tilde + Ograve ;00D2 latin capital letter O with grave + Oacute ;00D3 latin capital letter O with acute + Ocirc ;00D4 latin capital letter O with circumflex + Otilde ;00D5 latin capital letter O with tilde + Ouml ;00D6 latin capital letter O with diaeresis + times ;00D7 multiplication sign + Oslash ;00D8 latin capital letter O with stroke = latin capital letter O slash + Ugrave ;00D9 latin capital letter U with grave + Uacute ;00DA latin capital letter U with acute + Ucirc ;00DB latin capital letter U with circumflex + Uuml ;00DC latin capital letter U with diaeresis + Yacute ;00DD latin capital letter Y with acute + THORN ;00DE latin capital letter THORN + szlig ;00DF latin small letter sharp s = ess-zed + agrave ;00E0 latin small letter a with grave = latin small letter a grave + aacute ;00E1 latin small letter a with acute + acirc ;00E2 latin small letter a with circumflex + atilde ;00E3 latin small letter a with tilde + auml ;00E4 latin small letter a with diaeresis + aring ;00E5 latin small letter a with ring above = latin small letter a ring + aelig ;00E6 latin small letter ae = latin small ligature ae + ccedil ;00E7 latin small letter c with cedilla + egrave ;00E8 latin small letter e with grave + eacute ;00E9 latin small letter e with acute + ecirc ;00EA latin small letter e with circumflex + euml ;00EB latin small letter e with diaeresis + igrave ;00EC latin small letter i with grave + iacute ;00ED latin small letter i with acute + icirc ;00EE latin small letter i with circumflex + iuml ;00EF latin small letter i with diaeresis + eth ;00F0 latin small letter eth + ntilde ;00F1 latin small letter n with tilde + ograve ;00F2 latin small letter o with grave + oacute ;00F3 latin small letter o with acute + ocirc ;00F4 latin small letter o with circumflex + otilde ;00F5 latin small letter o with tilde + ouml ;00F6 latin small letter o with diaeresis + divide ;00F7 division sign + oslash ;00F8 latin small letter o with stroke, = latin small letter o slash + ugrave ;00F9 latin small letter u with grave + uacute ;00FA latin small letter u with acute + ucirc ;00FB latin small letter u with circumflex + uuml ;00FC latin small letter u with diaeresis + yacute ;00FD latin small letter y with acute + thorn ;00FE latin small letter thorn + yuml ;00FF latin small letter y with diaeresis + + ;; 24.3 Character entity references for symbols, mathematical symbols, and + ;; Greek letters + ;; Latin Extended-B + fnof ;0192 latin small f with hook = function = florin + ;; Greek + Alpha ;0391 greek capital letter alpha + Beta ;0392 greek capital letter beta + Gamma ;0393 greek capital letter gamma + Delta ;0394 greek capital letter delta + Epsilon ;0395 greek capital letter epsilon + Zeta ;0396 greek capital letter zeta + Eta ;0397 greek capital letter eta + Theta ;0398 greek capital letter theta + Iota ;0399 greek capital letter iota + Kappa ;039A greek capital letter kappa + Lambda ;039B greek capital letter lambda + Mu ;039C greek capital letter mu + Nu ;039D greek capital letter nu + Xi ;039E greek capital letter xi + Omicron ;039F greek capital letter omicron + Pi ;03A0 greek capital letter pi + Rho ;03A1 greek capital letter rho + Sigma ;03A3 greek capital letter sigma + Tau ;03A4 greek capital letter tau + Upsilon ;03A5 greek capital letter upsilon + Phi ;03A6 greek capital letter phi + Chi ;03A7 greek capital letter chi + Psi ;03A8 greek capital letter psi + Omega ;03A9 greek capital letter omega + alpha ;03B1 greek small letter alpha + beta ;03B2 greek small letter beta + gamma ;03B3 greek small letter gamma + delta ;03B4 greek small letter delta + epsilon ;03B5 greek small letter epsilon + zeta ;03B6 greek small letter zeta + eta ;03B7 greek small letter eta + theta ;03B8 greek small letter theta + iota ;03B9 greek small letter iota + kappa ;03BA greek small letter kappa + lambda ;03BB greek small letter lambda + mu ;03BC greek small letter mu + nu ;03BD greek small letter nu + xi ;03BE greek small letter xi + omicron ;03BF greek small letter omicron + pi ;03C0 greek small letter pi + rho ;03C1 greek small letter rho + sigmaf ;03C2 greek small letter final sigma + sigma ;03C3 greek small letter sigma + tau ;03C4 greek small letter tau + upsilon ;03C5 greek small letter upsilon + phi ;03C6 greek small letter phi + chi ;03C7 greek small letter chi + psi ;03C8 greek small letter psi + omega ;03C9 greek small letter omega + thetasym ;03D1 greek small letter theta symbol + upsih ;03D2 greek upsilon with hook symbol + piv ;03D6 greek pi symbol + ;; *** General Punctuation + bull ;2022 bullet = black small circle + hellip ;2026 horizontal ellipsis = three dot leader + prime ;2032 prime = minutes = feet + Prime ;2033 double prime = seconds = inches + oline ;203E overline = spacing overscore + frasl ;2044 fraction slash + ;; *** Letterlike Symbols + weierp ;2118 script capital P = power set = Weierstrass p + image ;2111 blackletter capital I = imaginary part + real ;211C blackletter capital R = real part symbol + trade ;2122 trade mark sign + alefsym ;2135 alef symbol = first transfinite cardinal + ;; *** Arrows + larr ;2190 leftwards arrow + uarr ;2191 upwards arrow + rarr ;2192 rightwards arrow + darr ;2193 downwards arrow + harr ;2194 left right arrow + crarr ;21B5 downwards arrow with corner leftwards = carriage return + lArr ;21D0 leftwards double arrow + uArr ;21D1 upwards double arrow + rArr ;21D2 rightwards double arrow + dArr ;21D3 downwards double arrow + hArr ;21D4 left right double arrow + ;; Mathematical Operators + forall ;2200 for all + part ;2202 partial differential + exist ;2203 there exists + empty ;2205 empty set = null set = diameter + nabla ;2207 nabla = backward difference + isin ;2208 element of + notin ;2209 not an element of + ni ;220B contains as member + prod ;220F n-ary product = product sign + sum ;2211 n-ary sumation + minus ;2212 minus sign + lowast ;2217 asterisk operator + radic ;221A square root = radical sign + prop ;221D proportional to + infin ;221E infinity + ang ;2220 angle + and ;2227 logical and = wedge + or ;2228 logical or = vee + cap ;2229 intersection = cap + cup ;222A union = cup + int ;222B integral + there4 ;2234 therefore + sim ;223C tilde operator = varies with = similar to + cong ;2245 approximately equal to + asymp ;2248 almost equal to = asymptotic to + ne ;2260 not equal to + equiv ;2261 identical to + le ;2264 less-than or equal to + ge ;2265 greater-than or equal to + sub ;2282 subset of + sup ;2283 superset of + nsub ;2284 not a subset of + sube ;2286 subset of or equal to + supe ;2287 superset of or equal to + oplus ;2295 circled plus = direct sum + otimes ;2297 circled times = vector product + perp ;22A5 up tack = orthogonal to = perpendicular + sdot ;22C5 dot operator + ;; Miscellaneous Technical + lceil ;2308 left ceiling = apl upstile + rceil ;2309 right ceiling + lfloor ;230A left floor = apl downstile + rfloor ;230B right floor + lang ;2329 left-pointing angle bracket = bra + rang ;232A right-pointing angle bracket = ket + ;; Geometric Shapes + loz ;25CA lozenge + ;; Miscellaneous Symbols + spades ;2660 black spade suit + clubs ;2663 black club suit = shamrock + hearts ;2665 black heart suit = valentine + diams ;2666 black diamond suit + + ;; 24.4 Character entity references for markup-significant and + ;; internationalization characters + ;; C0 Controls and Basic Latin + quot ;0022 quotation mark = APL quote + amp ;0026 ampersand + lt ;003C less-than sign + gt ;003E greater-than sign + ;; Latin Extended-A + OElig ;0152 latin capital ligature OE + oelig ;0153 latin small ligature oe + Scaron ;0160 latin capital letter S with caron + scaron ;0161 latin small letter s with caron + Yuml ;0178 latin capital letter Y with diaeresis + ;; Spacing Modifier Letters + circ ;02C6 modifier letter circumflex accent + tilde ;02DC small tilde + ;; General Punctuation + ensp ;2002 en space + emsp ;2003 em space + thinsp ;2009 thin space + zwnj ;200C zero width non-joiner + zwj ;200D zero width joiner + lrm ;200E left-to-right mark + rlm ;200F right-to-left mark + ndash ;2013 en dash + mdash ;2014 em dash + lsquo ;2018 left single quotation mark + rsquo ;2019 right single quotation mark + sbquo ;201A single low-9 quotation mark + ldquo ;201C left double quotation mark + rdquo ;201D right double quotation mark + bdquo ;201E double low-9 quotation mark + dagger ;2020 dagger + Dagger ;2021 double dagger + permil ;2030 per mille sign + lsaquo ;2039 single left-pointing angle quotation mark + rsaquo ;203A single right-pointing angle quotation mark + euro ;20AC euro sign + ) diff --git a/collects/meta/web/html/main.rkt b/collects/meta/web/html/main.rkt new file mode 100644 index 00000000..f778e81b --- /dev/null +++ b/collects/meta/web/html/main.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(provide (except-out (all-from-out racket/base) #%top) + (rename-out [top #%top]) + ;; to be used as a text language + (all-from-out scribble/text) + ;; provide a `text' alias + (rename-out [begin/text text]) + ;; main functionality + (all-from-out "xml.rkt" "html.rkt" "resource.rkt")) + +(require "xml.rkt" "html.rkt" "resource.rkt" + scribble/text (for-syntax racket/base)) + +(define-syntax (top stx) + (syntax-case stx () + [(_ . x) + (let ([x* (syntax-e #'x)]) + (if (and (symbol? x*) (regexp-match? #rx":$" (symbol->string x*))) + #''x + #'(#%top . x)))])) diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt new file mode 100644 index 00000000..b9ef57f0 --- /dev/null +++ b/collects/meta/web/html/resource.rkt @@ -0,0 +1,198 @@ +#lang racket/base + +;; Resources are referrable & renderable objects, (most are html pages) + +;; (resource path renderer referrer) creates and returns a new "resource" +;; value. The arguments are: +;; - `path': the path of the output file, relative to the working directory, +;; indicating where the resource file should be put at, also corresponding to +;; the URL it will be found at. It must be a `/'-separated relative string, +;; no `..', `.', or `//', and it can end in `/' (which will turn to +;; "index.html"). +;; - `renderer': a unary function that renders the resource, receiving the path +;; for the file to be created as an argument. This path will be different +;; than the `path' argument because this function is invoked in the target +;; directory. +;; - `referrer': a function accepting one or more arguments (and possibly +;; keywords) that produces a value to be used to refer to this resource +;; (using `a', `img', etc). The first value that will be passed to this +;; function will be the actual URL path, which depends on the currently +;; rendered page path -- the argument will be relative to it. +;; The resulting resource value is actually a rendering function that is +;; similar to the `referrer', except without the first URL argument -- when it +;; is called, it invokes the `referrer' function with the actual (relativized) +;; URL. Creating a resource registers the `renderer' to be executed when +;; rendering is initiated. Note that more resources can be created while +;; rendering; they will also be rendered in turn until no more resources are +;; created. + +(require racket/list racket/string scribble/text "xml.rkt") + +;; default file, urls to it will point to its directory instead, and a +;; /-suffixed path will render to this file +(define default-file "index.html") + +;; the currently rendered directory, as a list +(define rendered-dirpath (make-parameter '())) + +;; a mapping from path prefixes to urls (actually, any string) -- when two +;; paths are in the same prefix, links from one to the other are relative, but +;; if they're in different prefixes, the url will be used instead; the roots +;; are expected to be disjoint (= no "/foo" and "/foo/bar" roots) +(provide url-roots) +(define url-roots + ;; takes in a (listof (list prefix-string url-string)), and 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) + (make-parameter #f + (lambda (x) + (and (list? x) (pair? x) + (map (lambda (x) + (cons (regexp-match* #rx"[^/]+" (car x)) + (regexp-replace #rx"/$" (cadr x) ""))) + x))))) + +;; a utility for relative paths, taking the above `default-file' and +;; `url-roots' into consideration. +(define (relativize file tgtdir curdir) + (define file* (if (equal? file default-file) "" file)) + (define roots (url-roots)) + (define (make-rooted path) + (ormap (lambda (root+url) + (let loop ([r (car root+url)] [p path]) + (if (null? r) + `(,(cdr root+url) ,@p ,file*) + (and (pair? p) (loop (cdr r) (cdr p)))))) + roots)) + (define result + (let loop ([t tgtdir] [c curdir] [pfx '()]) + (cond + ;; find shared prefix + [(and (pair? t) (pair? c) (equal? (car t) (car c))) + (loop (cdr t) (cdr c) (cons (car t) pfx))] + ;; done + [(or (not roots) ; if there are no roots + (make-rooted (reverse pfx))) ; or if they share a root + ;; then make them relative + `(,@(map (lambda (_) "..") c) ,@t ,file*)] + ;; different roots => use the one for the target + [(make-rooted t)] + ;; otherwise throw an error + [else (error 'relativize "target url is not in any known root: ~a" + (string-join `(,@tgtdir ,file*) "/"))]))) + (if (equal? '("") result) "." (string-join result "/"))) +#| tests +(require tests/eli-tester) +(define R relativize) +(let () + (test do (test (R "bleh.txt" '() '() ) => "bleh.txt" + (R "bleh.txt" '("x") '() ) => "x/bleh.txt" + (R "bleh.txt" '("x" "y") '() ) => "x/y/bleh.txt" + (R "bleh.txt" '() '("x") ) => "../bleh.txt" + (R "bleh.txt" '("x") '("x") ) => "bleh.txt" + (R "bleh.txt" '("x" "y") '("x") ) => "y/bleh.txt" + (R "bleh.txt" '() '("x" "y")) => "../../bleh.txt" + (R "bleh.txt" '("x") '("x" "y")) => "../bleh.txt" + (R "bleh.txt" '("x" "y") '("x" "y")) => "bleh.txt" + (R "bleh.txt" '("x" "y") '("y" "x")) => "../../x/y/bleh.txt" + (R "index.html" '() '() ) => "." + (R "index.html" '("x") '() ) => "x/" + (R "index.html" '("x" "y") '() ) => "x/y/" + (R "index.html" '() '("x") ) => "../" + (R "index.html" '("x") '("x") ) => "." + (R "index.html" '("x" "y") '("x") ) => "y/" + (R "index.html" '() '("x" "y")) => "../../" + (R "index.html" '("x") '("x" "y")) => "../" + (R "index.html" '("x" "y") '("x" "y")) => "." + (R "index.html" '("x" "y") '("y" "x")) => "../../x/y/") + do (parameterize ([url-roots '(["/x" "/X/"] ["/y" "/Y/"])]) + (test (R "bleh.txt" '() '() ) =error> "not in any" + (R "bleh.txt" '("x") '() ) => "/X/bleh.txt" + (R "bleh.txt" '("x" "y") '() ) => "/X/y/bleh.txt" + (R "bleh.txt" '() '("x") ) =error> "not in any" + (R "bleh.txt" '("x") '("x") ) => "bleh.txt" + (R "bleh.txt" '("x" "y") '("x") ) => "y/bleh.txt" + (R "bleh.txt" '() '("x" "y")) =error> "not in any" + (R "bleh.txt" '("x") '("x" "y")) => "../bleh.txt" + (R "bleh.txt" '("x" "y") '("x" "y")) => "bleh.txt" + (R "bleh.txt" '("x" "y") '("y" "x")) => "/X/y/bleh.txt" + (R "index.html" '() '() ) =error> "not in any" + (R "index.html" '("x") '() ) => "/X/" + (R "index.html" '("x" "y") '() ) => "/X/y/" + (R "index.html" '() '("x") ) =error> "not in any" + (R "index.html" '("x") '("x") ) => "." + (R "index.html" '("x" "y") '("x") ) => "y/" + (R "index.html" '() '("x" "y")) =error> "not in any" + (R "index.html" '("x") '("x" "y")) => "../" + (R "index.html" '("x" "y") '("x" "y")) => "." + (R "index.html" '("x" "y") '("y" "x")) => "/X/y/")))) +|# + +;; utility for keeping a list of renderer thunks +(define-values [add-renderer get/reset-renderers] + (let ([l '()] [s (make-semaphore 1)]) + ;; map paths to #t -- used to avoid overwriting files + (define t (make-hash)) + (define-syntax-rule (S body) (call-with-semaphore s (lambda () body))) + (values (lambda (path renderer) + (S (if (hash-ref t path #f) + (error 'resource "path used for two resources: ~e" path) + (begin (hash-set! t path #t) (set! l (cons renderer l)))))) + (lambda () (S (begin0 (reverse l) (set! l '()))))))) + +;; `#:exists' determines what happens when the render destination exists, it +;; 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")) + (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))) + (add-renderer path render) + (make-keyword-procedure + (lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args)) + (lambda args (apply referrer (url) args))))) + +;; a convenient utility to create renderers from some output function (like +;; `output-xml' or `display') and some content +(provide file-writer) +(define ((file-writer writer content) file) + (call-with-output-file file (lambda (o) (writer content o)))) + +;; runs all renderers, and any renderers that might have been added on the way +(provide render-all) +(define (render-all) + (printf "Rendering...\n") + (let loop () + (let ([todo (get/reset-renderers)]) + (unless (null? todo) + (for-each (lambda (r) (r)) todo) + (loop)))) ; if more were created + (printf "Rendering done.\n")) diff --git a/collects/meta/web/html/xml.rkt b/collects/meta/web/html/xml.rkt new file mode 100644 index 00000000..721a4e22 --- /dev/null +++ b/collects/meta/web/html/xml.rkt @@ -0,0 +1,147 @@ +#lang racket/base + +;; XML-like objects and functions, with rendering + +(require scribble/text) + +;; ---------------------------------------------------------------------------- +;; Represent attribute names as `foo:' symbols. They are made self-quoting in +;; the language. A different option would be to use the usual racket keyword +;; arguments, but that tends to have problems like disallowing repeated uses of +;; the same keyword, sorting the keywords alphabetically, and ambiguity when +;; some keywords are meant to do the usual thing (customize a function) instead +;; of representing an attribute. It's more convenient to just have a separate +;; mechanism for this, so racket keywords are still used in the same way, and +;; orthogonal to specifying attributes. Another possibility is to have a new +;; type, with `foo:' evaluating to instances -- but it's often convenient to +;; pass them around as quoted lists. + +(define attribute->symbol + (let ([t (make-weak-hasheq)]) + (lambda (x) + (and (symbol? x) + (hash-ref! t x + (lambda () + (let ([m (regexp-match #rx"^(.*):$" (symbol->string x))]) + (and m (string->symbol (cadr m)))))))))) + +(provide attribute?) +(define attribute? attribute->symbol) + +(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))])))) + +;; ---------------------------------------------------------------------------- +;; An output that handles xml quoting, customizable + +;; TODO: make this more conveniently customizable and extensible +(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))))))) + +(provide xml-writer) +(define xml-writer (make-parameter write-string/xml-quote)) + +(provide output-xml) +(define (output-xml content [p (current-output-port)]) + (output (disable-prefix (with-writer (xml-writer) content)) p)) + +;; ---------------------------------------------------------------------------- +;; Structs for xml data: elements, literals, entities + +(provide make-element) +(define-struct element (tag attrs body [cache #:auto #:mutable]) + #:transparent #:omit-define-syntaxes #:auto-value #f + #:property prop:procedure + (lambda (e) + (unless (element-cache e) (set-element-cache! e (element->output e))) + (element-cache e))) + +(provide element) +(define (element tag . args) + (let-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)))) + +;; 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 "")))))) + +;; ---------------------------------------------------------------------------- +;; Literals + +;; literal "struct" for things that are not escaped +(provide literal) +(define (literal . contents) (with-writer #f contents)) + +;; entities are implemented as literals +(provide entity) +(define (entity x) (literal "&" (and (number? x) "#") x ";")) + +;; comments and cdata +(provide comment) +(define (comment #:newlines? [newlines? #f] . body) + (let ([newline (and newlines? "\n")]) + (literal ""))) +(provide cdata) +(define (cdata #:newlines? [newlines? #t] #:line-prefix [pfx #f] . body) + (let ([newline (and newlines? "\n")]) + (literal pfx ""))) + +;; ---------------------------------------------------------------------------- +;; Template definition forms + +(provide define/provide-elements/empty + define/provide-elements/not-empty + define/provide-entities) +(define-syntax-rule (define/provide-elements/empty tag ...) + (begin (provide tag ...) + (define (tag . args) (apply element 'tag args)) ...)) +(define-syntax-rule (define/provide-elements/not-empty tag ...) + (begin (provide tag ...) + (define (tag . args) (apply element/not-empty 'tag args)) ...)) +(define-syntax-rule (define/provide-entities ent ...) + (begin (provide ent ...) + (define ent ; use string-append to make it a little faster + (literal (string-append "&" (symbol->string 'ent) ";"))) + ...))