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

Adding prototype template language

Browse Source 
svn: r11343
This commit is contained in:
Jay McCarthy 2008-08-19 20:44:34 +00:00
parent a16f879e24
commit 3d8b5e748d
7 changed files with 159 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/web-server/template/examples/basic.scrbl Normal file
View File

@ -0,0 +1,24 @@
#lang web-server/template
@(title clients client-surname client-firstname client-email)
<html>
<head><title>@|title|</title></head>
<body>
<table>
@for[([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"
@; `(["First1" "Last1" "email1"]
@; ["First2" "Last2" "email2"]
@; ["First3" "Last3" "email3"]
@; ["First4" "Last4" "email4"]
@; ["First5" "Last5" "email5"])
@; second first third)

15
collects/web-server/template/examples/if.scrbl Normal file
View File

@ -0,0 +1,15 @@
#lang web-server/template
@(monkeys monkey-limit monkey-minimum)
@(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 5 10 1)
@;"\n<p>There are just enough monkeys!</p>\n"
@; (template 11 10 1)
@;"\n<p>There are too many monkeys!</p>\n"
@; (template 0 10 1)
@;"\n<p>There aren't enough monkeys!</p>\n"
@;

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

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

24
collects/web-server/template/examples/module.scrbl Normal file
View File

@ -0,0 +1,24 @@
#lang web-server/template
@(require "module-test.ss")
@(title clients)
<html>
<head><title>@|title|</title></head>
<body>
<table>
@for[([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"
@; (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")))

40
collects/web-server/template/lang.ss Normal file
View File

@ -0,0 +1,40 @@
#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-syntax (*module-begin stx)
(syntax-case stx (require)
[(_ id (require r ...) nl (fv ...) body ...)
#'(#%module-begin
(require r ...)
(define-template id (fv ...) (#%string-append body ...))
(provide id))]
[(_ id (fv ...) body ...)
#'(#%module-begin
(define-template id (fv ...) (#%string-append body ...))
(provide id))]))
#;(define-syntax (define-template stx)
(syntax-case stx ()
[(_ id body)
(with-syntax ([(pmb body)
(local-expand
(quasisyntax/loc stx body)
'expression
empty)])
(let ([fvars (free-vars #'body)])
(quasisyntax/loc stx
(define (id #,@fvars)
body))))]))
(define-syntax (define-template stx)
(syntax-case stx ()
[(_ id (fv ...) body)
(quasisyntax/loc stx
(define (id fv ...)
body))]))

21
collects/web-server/template/lang/reader.ss Normal file
View File

@ -0,0 +1,21 @@
#lang scheme/base
(require (prefix-in scribble: scribble/reader))
(provide (rename-out [*read read])
(rename-out [*read-syntax read-syntax]))
(define (*read [inp (current-input-port)])
(wrap inp (scribble:read-inside inp)))
(define (*read-syntax [src #f] [port (current-input-port)])
(wrap port (scribble:read-syntax-inside src port)))
(define (wrap port body)
(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)]
[id 'template])
`(module ,name web-server/template/lang
(#%module-begin ,id . ,body))))

31
collects/web-server/template/lib.ss Normal file
View File

@ -0,0 +1,31 @@
#lang scheme
(provide for)
(define-syntax for
(syntax-rules ()
[(_ (for-clause ...) body ...)
(apply
string-append
(for/list (for-clause ...)
(#%string-append 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 ...)))]))]))