From 47133090f59a127b3db4094610cc4f08690a575d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 20 Aug 2008 16:04:44 +0000 Subject: [PATCH] Streamline svn: r11357 --- .../web-server/template/examples/basic.scrbl | 28 ++++---- .../web-server/template/examples/if.scrbl | 27 ++++--- .../web-server/template/examples/module.scrbl | 20 +++--- collects/web-server/template/lang.ss | 70 ++++++++++++------- collects/web-server/template/lang/reader.ss | 33 ++++++--- collects/web-server/template/lib.ss | 7 +- 6 files changed, 119 insertions(+), 66 deletions(-) diff --git a/collects/web-server/template/examples/basic.scrbl b/collects/web-server/template/examples/basic.scrbl index 4e7850652e..d9264185df 100644 --- a/collects/web-server/template/examples/basic.scrbl +++ b/collects/web-server/template/examples/basic.scrbl @@ -1,13 +1,12 @@ #lang web-server/template -@(title clients client-surname client-firstname client-email) - @|title| + @$title - @for[([c clients])]{ + @in[c $clients]{ - + }
@(client-surname c), @(client-firstname c) - @(client-email c)@($client-surname c), @($client-firstname c) + @($client-email c)
@@ -15,10 +14,15 @@ @; 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 +@;{ + (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) + } \ No newline at end of file diff --git a/collects/web-server/template/examples/if.scrbl b/collects/web-server/template/examples/if.scrbl index 731a13154c..8906143eee 100644 --- a/collects/web-server/template/examples/if.scrbl +++ b/collects/web-server/template/examples/if.scrbl @@ -1,15 +1,22 @@ #lang web-server/template -@(monkeys monkey-limit monkey-minimum) -@(if (monkeys . > . monkey-limit) +@(if ($monkeys . > . $monkey-limit) @t{

There are too many monkeys!

} - @t{@(if (monkeys . < . monkey-minimum) + @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 +@;{ +> (template #:monkeys 5 + #:monkey-limit 10 + #:monkey-minimum 1) +"

There are just enough monkeys!

\n\n" +> (template #:monkeys 0 + #:monkey-limit 10 + #:monkey-minimum 1) +"

There aren't enough monkeys!

\n\n" +> (template #:monkeys 11 + #:monkey-limit 10 + #:monkey-minimum 1) +"

There are too many monkeys!

\n\n" +> +} \ No newline at end of file diff --git a/collects/web-server/template/examples/module.scrbl b/collects/web-server/template/examples/module.scrbl index c224dc2237..466efa9bd7 100644 --- a/collects/web-server/template/examples/module.scrbl +++ b/collects/web-server/template/examples/module.scrbl @@ -1,11 +1,10 @@ #lang web-server/template @(require "module-test.ss") -@(title clients) - @|title| + @$title - @for[([client clients])]{ + @in[client $clients]{ @@ -16,9 +15,12 @@ @; 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 +@;{ + (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"))) + } \ No newline at end of file diff --git a/collects/web-server/template/lang.ss b/collects/web-server/template/lang.ss index 7560230f27..576b75f761 100644 --- a/collects/web-server/template/lang.ss +++ b/collects/web-server/template/lang.ss @@ -7,34 +7,54 @@ (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 ...) nl (fv ...) body ...) - #'(#%module-begin + [(_ id (require r ...) body ...) + (quasisyntax/loc stx + (#%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-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 (fv ...) body) - (quasisyntax/loc stx - (define (id fv ...) - body))])) + [(_ 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))))])) diff --git a/collects/web-server/template/lang/reader.ss b/collects/web-server/template/lang/reader.ss index d6343ad112..9e7879c0c3 100644 --- a/collects/web-server/template/lang/reader.ss +++ b/collects/web-server/template/lang/reader.ss @@ -4,18 +4,33 @@ (provide (rename-out [*read read]) (rename-out [*read-syntax read-syntax])) -(define (*read [inp (current-input-port)]) - (wrap inp (scribble:read-inside inp))) +; Adapted from syntax/module-reader and scribble/reader -(define (*read-syntax [src #f] [port (current-input-port)]) - (wrap port (scribble:read-syntax-inside src port))) +(define (*read in modpath line col pos) + (wrap in (scribble:read-inside in) modpath #f line col pos)) -(define (wrap port body) +(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 #"")))) + (string->symbol + (path->string (path-replace-suffix name #"")))) 'page)] - [id 'template]) - `(module ,name web-server/template/lang - (#%module-begin ,id . ,body)))) + [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))) \ No newline at end of file diff --git a/collects/web-server/template/lib.ss b/collects/web-server/template/lib.ss index 8cf2bc626e..cb3b4f3341 100644 --- a/collects/web-server/template/lib.ss +++ b/collects/web-server/template/lib.ss @@ -9,8 +9,13 @@ (for/list (for-clause ...) (#%string-append body ...)))])) -(provide (rename-out [#%string-append t])) +(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 ()
@(client-surname client), @(client-fname client) @(client-email client)