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

Generic (X)HTML generation framework

Browse Source 
(Will later move into the scribble collection.)
This commit is contained in:
Eli Barzilay 2010-06-04 14:11:19 -04:00
parent 6197de9a09
commit 9a0b78d9ad
6 changed files with 838 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/meta/web/README Normal file
View File

@ -0,0 +1,6 @@
* html: generic shared code for (X)HTML generation (tag output and
resource rendering and referring).
* common: specific code for the PLT web pages.
* other stuff: actual content.

4
collects/meta/web/html.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
(require "html/main.rkt")
(provide (all-from-out "html/main.rkt"))

462
collects/meta/web/html/html.rkt Normal file
View File

@ -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
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""
" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\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
)

21
collects/meta/web/html/main.rkt Normal file
View File

@ -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)))]))

198
collects/meta/web/html/resource.rkt Normal file
View File

@ -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"))

147
collects/meta/web/html/xml.rkt Normal file
View File

@ -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))
[(#\&) "&amp;"]
[(#\<) "&lt;"]
[(#\>) "&gt;"]
[(#\") "&quot;"])
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 "</" tag ">"))))))
;; ----------------------------------------------------------------------------
;; 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 "<!--" 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 "]]>")))
;; ----------------------------------------------------------------------------
;; 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) ";")))
...))