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

Re Eli

Browse Source 
svn: r11445
This commit is contained in:
Jay McCarthy 2008-08-26 23:27:06 +00:00
parent 27c9c2a22f
commit 2e8d5ed971
11 changed files with 120 additions and 212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/web-server/template/examples/basic.html Normal file
View File

@ -0,0 +1,15 @@
<html>
<head><title>@title </title></head>
<body>
<table>
@for/list[([c @clients])]{
@t{
<tr>
<td>@(client-surname c), @(client-firstname c)</td>
<td><a href="mailto:@(client-email c)">@(client-email c)</a></td>
</tr>
}
}
</table>
</body>
</html>

28
collects/web-server/template/examples/basic.scrbl
View File

@ -1,28 +0,0 @@
#lang web-server/template
<html>
<head><title>@$title </title></head>
<body>
<table>
@in[c $clients]{
<tr>
<td>@($client-surname c), @($client-firstname c)
<td><a href="mailto:@($client-email c)">@($client-email c)</a></td>
</tr>
}
</table>
</body>
</html>
@; Example:
@;{
(template #:title "Title"
#:clients
`(["First1" "Last1" "email1"]
["First2" "Last2" "email2"]
["First3" "Last3" "email3"]
["First4" "Last4" "email4"]
["First5" "Last5" "email5"])
#:client-surname second
#:client-firstname first
#:client-email third)
}

5
collects/web-server/template/examples/if.html Normal file
View File

@ -0,0 +1,5 @@
@(if (@monkeys . > . @monkey-limit)
@t{<p>There are too many monkeys!</p>}
@(if (@monkeys . < . @monkey-minimum)
@t{<p>There aren't enough monkeys!</p>}
@t{<p>There are just enough monkeys!</p>}))

22
collects/web-server/template/examples/if.scrbl
View File

@ -1,22 +0,0 @@
#lang web-server/template
@(if ($monkeys . > . $monkey-limit)
@t{<p>There are too many monkeys!</p>}
@t{@(if ($monkeys . < . $monkey-minimum)
@t{<p>There aren't enough monkeys!</p>}
@t{<p>There are just enough monkeys!</p>})})
@;{
> (template #:monkeys 5
#:monkey-limit 10
#:monkey-minimum 1)
"<p>There are just enough monkeys!</p>\n\n"
> (template #:monkeys 0
#:monkey-limit 10
#:monkey-minimum 1)
"<p>There aren't enough monkeys!</p>\n\n"
> (template #:monkeys 11
#:monkey-limit 10
#:monkey-minimum 1)
"<p>There are too many monkeys!</p>\n\n"
>
}

4
collects/web-server/template/examples/module-test.ss
View File

@ -1,4 +0,0 @@
#lang scheme
(define-struct client (fname surname email))
(provide (struct-out client))

26
collects/web-server/template/examples/module.scrbl
View File

@ -1,26 +0,0 @@
#lang web-server/template
@(require "module-test.ss")
<html>
<head><title>@$title </title></head>
<body>
<table>
@in[client $clients]{
<tr>
<td>@(client-surname client), @(client-fname client)
<td><a href="mailto:@(client-email client)">@(client-email client)</a></td>
</tr>
}
</table>
</body>
</html>
@; Example:
@;{
(template #:title "Title"
#:clients
(list (make-client "First1" "Last1" "email1")
(make-client "First2" "Last2" "email2")
(make-client "First3" "Last3" "email3")
(make-client "First4" "Last4" "email4")
(make-client "First5" "Last5" "email5")))
}

89
collects/web-server/template/examples/run.ss Normal file
View File

@ -0,0 +1,89 @@
#lang scheme
(require scheme/include
(for-syntax scheme)
(prefix-in text: scribble/text)
(for-syntax (prefix-in text: scribble/text))
(for-syntax (prefix-in at: scribble/reader)))
; XXX I have to do this because without it there is an infinite loop.
; at:read-syntax-inside returns #'() instead of eof
(define-for-syntax (*read-syntax . args)
(define r (apply at:read-syntax-inside args))
(if (eof-object? r) r
(if (null? (syntax->datum r))
eof
r)))
(define-syntax (include-template stx)
(syntax-case stx ()
[(_ a-path)
; XXX Not desireable, but necessary to get at the body,
; rather than it being used as a string applied to the rest
(with-syntax ([(begin (#%app body ...))
(local-expand
(with-syntax ([_stx stx])
(syntax/loc stx
(include-at/relative-to/reader
_stx _stx
(file a-path) *read-syntax)))
'module-begin
empty)
])
(syntax/loc stx
(with-output-to-string
(begin/show body ...))))]))
(define-syntax with-output-to-string
(syntax-rules ()
[(_ e ...)
(let ([os (open-output-string)])
(parameterize ([current-output-port os])
e ...)
(get-output-string os))]))
(define-syntax begin/show
(syntax-rules ()
[(_ e) e]
[(_ e ...)
; XXX If scribble/text shared "show", then I would use it here
(begin (display e) ...)]))
(define t list)
; Examples
(include-template "static.html")
(define (basic-template title clients client-surname client-firstname client-email)
(include-template "basic.html"))
(basic-template "Title"
(list (list "First 1" "Second 1" "Third 1")
(list "First 2" "Second 2" "Third 2")
(list "First 3" "Second 3" "Third 3")
(list "First 4" "Second 4" "Third 4"))
first second third)
(local ()
(define-struct client (surname firstname email))
(basic-template "Title"
(list (make-client "First 1" "Second 1" "Third 1")
(make-client "First 2" "Second 2" "Third 2")
(make-client "First 3" "Second 3" "Third 3")
(make-client "First 4" "Second 4" "Third 4"))
client-surname client-firstname client-email))
(define (if-template #:monkeys monkeys
#:monkey-limit monkey-limit
#:monkey-minimum monkey-minimum)
(include-template "if.html"))
(if-template #:monkeys 5
#:monkey-limit 10
#:monkey-minimum 2)
(if-template #:monkeys 11
#:monkey-limit 10
#:monkey-minimum 2)
(if-template #:monkeys 1
#:monkey-limit 10
#:monkey-minimum 2)

11
collects/web-server/template/examples/static.html Normal file
View File

@ -0,0 +1,11 @@
<html>
<head><title>Title</title></head>
<body>
<table>
<tr>
<td>Example, Mr.</td>
<td><a href="mailto:example@"@"foo.com">example@"@"foo.com</a></td>
</tr>
</table>
</body>
</html>

60
collects/web-server/template/lang.ss
View File

@ -1,60 +0,0 @@
#lang scheme
(require (for-syntax scheme)
web-server/template/lib)
(provide (except-out (all-from-out scheme) #%module-begin)
(rename-out [*module-begin #%module-begin])
(all-from-out web-server/template/lib))
(define-for-syntax (ids stx)
(syntax-case stx ()
[(e ...)
(apply append (map ids (syntax->list #'(e ...))))]
[e (and (identifier? #'e)
(equal? #\$ (string-ref (symbol->string (syntax->datum #'e)) 0)))
(list #'e)]
[_ empty]))
(define-for-syntax (uniq ls)
(hash-map
(foldl (lambda (e a) (hash-set a (syntax->datum e) e))
(make-immutable-hash empty) ls)
(lambda (k v) v)))
(define-syntax (*module-begin stx)
(syntax-case stx (require)
[(_ id (require r ...) body ...)
(quasisyntax/loc stx
(#%module-begin
(require r ...)
(define-template id (#%string-append body ...))
(provide id)))]
[(_ id body ...)
(quasisyntax/loc stx
(#%module-begin
(define-template id (#%string-append body ...))
(provide id)))]))
(define-syntax (define-template stx)
(syntax-case stx ()
[(_ id body)
(let ([fv-stxs (uniq (ids #'body))])
(with-syntax ([(arg ...)
(foldl (lambda (i a)
(quasisyntax/loc i
(#,(datum->syntax
i
(string->keyword
(substring
(symbol->string
(syntax->datum i))
1))
i)
#,i
#,@a)))
#'()
fv-stxs)])
(quasisyntax/loc stx
(define (id arg ...)
body))))]))

36
collects/web-server/template/lang/reader.ss
View File

@ -1,36 +0,0 @@
#lang scheme/base
(require (prefix-in scribble: scribble/reader))
(provide (rename-out [*read read])
(rename-out [*read-syntax read-syntax]))
; Adapted from syntax/module-reader and scribble/reader
(define (*read in modpath line col pos)
(wrap in (scribble:read-inside in) modpath #f line col pos))
(define (*read-syntax src in modpath line col pos)
(wrap in (scribble:read-syntax-inside src in) modpath src line col pos))
(define (wrap port body modpath src line col pos)
(let* ([p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol
(path->string (path-replace-suffix name #""))))
'page)]
[tag-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f v
(vector src line col pos
(- (or (syntax-position modpath)
(add1 pos))
pos)))
v))]
[lib 'web-server/template/lang]
[lib-src (lambda (v)
(if (syntax? modpath)
(datum->syntax #f lib modpath modpath)
v))])
`(,(tag-src 'module) ,(tag-src name) ,(lib-src lib)
template . ,body)))

36
collects/web-server/template/lib.ss
View File

@ -1,36 +0,0 @@
#lang scheme
(provide for)
(define-syntax for
(syntax-rules ()
[(_ (for-clause ...) body ...)
(apply
string-append
(for/list (for-clause ...)
(#%string-append body ...)))]))
(provide in)
(define-syntax in
(syntax-rules ()
[(_ x xs body ...)
(for ([x xs]) body ...)]))
(provide (rename-out [#%string-append t]))
(provide #%string-append)
(define-syntax (#%string-append stx)
(syntax-case stx ()
[(_)
(syntax/loc stx "")]
[(_ e)
(syntax/loc stx e)]
[(_ e1 e2 e ...)
(let ([e1* (syntax->datum #'e1)]
[e2* (syntax->datum #'e2)])
(cond
[(and (string? e1*) (string? e2*))
(quasisyntax/loc stx
(#%string-append #,(datum->syntax stx (string-append e1* e2*) stx)
e ...))]
[else
(syntax/loc stx
(string-append e1 (#%string-append e2 e ...)))]))]))