From 3d8b5e748dd1a27910f77cd264c3735bf9b98164 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Aug 2008 20:44:34 +0000 Subject: [PATCH] Adding prototype template language svn: r11343 --- .../web-server/template/examples/basic.scrbl | 24 +++++++++++ .../web-server/template/examples/if.scrbl | 15 +++++++ .../template/examples/module-test.ss | 4 ++ .../web-server/template/examples/module.scrbl | 24 +++++++++++ collects/web-server/template/lang.ss | 40 +++++++++++++++++++ collects/web-server/template/lang/reader.ss | 21 ++++++++++ collects/web-server/template/lib.ss | 31 ++++++++++++++ 7 files changed, 159 insertions(+) create mode 100644 collects/web-server/template/examples/basic.scrbl create mode 100644 collects/web-server/template/examples/if.scrbl create mode 100644 collects/web-server/template/examples/module-test.ss create mode 100644 collects/web-server/template/examples/module.scrbl create mode 100644 collects/web-server/template/lang.ss create mode 100644 collects/web-server/template/lang/reader.ss create mode 100644 collects/web-server/template/lib.ss diff --git a/collects/web-server/template/examples/basic.scrbl b/collects/web-server/template/examples/basic.scrbl new file mode 100644 index 0000000000..4e7850652e --- /dev/null +++ b/collects/web-server/template/examples/basic.scrbl @@ -0,0 +1,24 @@ +#lang web-server/template +@(title clients client-surname client-firstname client-email) + + @|title| + + + @for[([c clients])]{ + + + + } +
@(client-surname c), @(client-firstname c) + @(client-email c)
+ + + +@; Example: +@; (template "Title" +@; `(["First1" "Last1" "email1"] +@; ["First2" "Last2" "email2"] +@; ["First3" "Last3" "email3"] +@; ["First4" "Last4" "email4"] +@; ["First5" "Last5" "email5"]) +@; second first third) \ No newline at end of file diff --git a/collects/web-server/template/examples/if.scrbl b/collects/web-server/template/examples/if.scrbl new file mode 100644 index 0000000000..731a13154c --- /dev/null +++ b/collects/web-server/template/examples/if.scrbl @@ -0,0 +1,15 @@ +#lang web-server/template +@(monkeys monkey-limit monkey-minimum) +@(if (monkeys . > . monkey-limit) + @t{

There are too many monkeys!

} + @t{@(if (monkeys . < . monkey-minimum) + @t{

There aren't enough monkeys!

} + @t{

There are just enough monkeys!

})}) + +@; (template 5 10 1) +@;"\n

There are just enough monkeys!

\n" +@; (template 11 10 1) +@;"\n

There are too many monkeys!

\n" +@; (template 0 10 1) +@;"\n

There aren't enough monkeys!

\n" +@; \ No newline at end of file diff --git a/collects/web-server/template/examples/module-test.ss b/collects/web-server/template/examples/module-test.ss new file mode 100644 index 0000000000..a2f9d53440 --- /dev/null +++ b/collects/web-server/template/examples/module-test.ss @@ -0,0 +1,4 @@ +#lang scheme + +(define-struct client (fname surname email)) +(provide (struct-out client)) \ No newline at end of file diff --git a/collects/web-server/template/examples/module.scrbl b/collects/web-server/template/examples/module.scrbl new file mode 100644 index 0000000000..c224dc2237 --- /dev/null +++ b/collects/web-server/template/examples/module.scrbl @@ -0,0 +1,24 @@ +#lang web-server/template +@(require "module-test.ss") +@(title clients) + + @|title| + + + @for[([client clients])]{ + + + + } +
@(client-surname client), @(client-fname client) + @(client-email client)
+ + + +@; 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"))) \ No newline at end of file diff --git a/collects/web-server/template/lang.ss b/collects/web-server/template/lang.ss new file mode 100644 index 0000000000..7560230f27 --- /dev/null +++ b/collects/web-server/template/lang.ss @@ -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))])) diff --git a/collects/web-server/template/lang/reader.ss b/collects/web-server/template/lang/reader.ss new file mode 100644 index 0000000000..d6343ad112 --- /dev/null +++ b/collects/web-server/template/lang/reader.ss @@ -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)))) diff --git a/collects/web-server/template/lib.ss b/collects/web-server/template/lib.ss new file mode 100644 index 0000000000..8cf2bc626e --- /dev/null +++ b/collects/web-server/template/lib.ss @@ -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 ...)))]))]))