diff --git a/collects/honu/main.ss b/collects/honu/main.ss index e410ba8448..e3d65b245e 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1295,36 +1295,38 @@ [exprs (let ([def-ctx (syntax-local-make-definition-context)] [ctx (generate-expand-context)]) - (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) - (apply - append - (map (lambda (expr) - (let ([expr (local-expand - expr - ctx - block-expand-stop-forms - def-ctx)]) - (syntax-case expr (begin define-values define-syntaxes) - [(begin . rest) - (loop (syntax->list #'rest))] - [(define-syntaxes (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([rhs (local-transformer-expand - #'rhs - 'expression - null)]) - (syntax-local-bind-syntaxes - (syntax->list #'(id ...)) - #'rhs def-ctx) - (list #'(define-syntaxes (id ...) rhs)))] - [(define-values (id ...) rhs) - (andmap identifier? (syntax->list #'(id ...))) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (list expr))] - [else - (list expr)]))) - exprs))))]) + (begin0 + (let loop ([exprs (cddddr (cdr (syntax->list stx)))]) + (apply + append + (map (lambda (expr) + (let ([expr (local-expand + expr + ctx + block-expand-stop-forms + def-ctx)]) + (syntax-case expr (begin define-values define-syntaxes) + [(begin . rest) + (loop (syntax->list #'rest))] + [(define-syntaxes (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes + (syntax->list #'(id ...)) + #'rhs def-ctx) + (list #'(define-syntaxes (id ...) rhs)))] + [(define-values (id ...) rhs) + (andmap identifier? (syntax->list #'(id ...))) + (let ([ids (syntax->list #'(id ...))]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list expr))] + [else + (list expr)]))) + exprs))) + (internal-definition-context-seal def-ctx)))]) #`(let () #,@(let loop ([exprs exprs][prev-defns null][prev-exprs null]) (cond diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 1e72899af5..c9b28bb194 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -386,6 +386,7 @@ [else (list expr)]))) exprs)))]) + (internal-definition-context-seal def-ctx) (let loop ([exprs exprs] [prev-stx-defns null] [prev-defns null] diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index a99eedf6b5..cf507a4e3f 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -667,6 +667,7 @@ (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) + (internal-definition-context-seal def-ctx) (make-parsed-unit imports renames vars diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 29443d50ca..f05c7f8691 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -18,7 +18,7 @@ (provide (rename build-siginfo make-siginfo) siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype unprocess-link-record-bind unprocess-link-record-use - set!-trans-extract do-identifier + set!-trans-extract process-tagged-import process-tagged-export lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names map-sig split-requires apply-mac complete-exports complete-imports check-duplicate-subs @@ -186,20 +186,17 @@ (lambda (x) x) sig))) - ;; do-prefix : sig syntax-object -> sig + ;; do-prefix : id id -> id ;; ensures that pid is an identifier - (define (do-prefix sig pid) - (check-id pid) - (let ((p (syntax-e pid))) - (map-sig - (lambda (id) - (datum->syntax-object - id - (string->symbol (format "~a~a" p (syntax-e id))))) - (lambda (x) x) - sig))) + (define (do-prefix stx pid) + (if (identifier? stx) + (datum->syntax-object + stx + (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx))) + stx) + stx)) - ;; do-only : sig (listof identifier) -> sig + ;; do-only/except : sig (listof identifier) -> sig ;; ensures that only-ids are identifiers and are mentioned in the signature (define (do-only/except sig only/except-ids put get) (check-module-id-subset only/except-ids @@ -217,22 +214,22 @@ sig))) ;; do-identifier : identifier (box (cons identifier siginfo)) -> sig - (define (do-identifier spec res bind?) + (define (do-identifier spec res bind? add-prefix) (let* ((sig (lookup-signature spec)) (vars (signature-vars sig)) (vals (signature-val-defs sig)) (stxs (signature-stx-defs sig)) (delta-introduce (if bind? - (let ([f (make-syntax-delta-introducer - spec - (signature-orig-binder sig))]) + (let ([f (syntax-local-make-delta-introducer + spec)]) (lambda (id) (syntax-local-introduce (f id)))) values))) (set-box! res (cons spec (signature-siginfo sig))) (map-sig (lambda (id) (syntax-local-introduce (syntax-local-get-shadower - (delta-introduce id)))) + (add-prefix + (delta-introduce id))))) syntax-local-introduce (list (map cons vars vars) (map @@ -301,43 +298,47 @@ (check-tagged-spec-syntax spec import? identifier?) (syntax-case spec (tag) ((tag sym spec) - (let ([s (process-import/export #'spec res bind?)]) + (let ([s (process-import/export #'spec res bind? values)]) (list (cons (syntax-e #'sym) (cdr (unbox res))) (cons (syntax-e #'sym) (car (unbox res))) s))) ((tag . _) (raise-stx-err "expected (tag symbol )" spec)) - (_ (let ([s (process-import/export spec res bind?)]) + (_ (let ([s (process-import/export spec res bind? values)]) (list (cons #f (cdr (unbox res))) (cons #f (car (unbox res))) s))))) + (define (add-prefixes add-prefix l) + (map add-prefix (syntax->list l))) ;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig - (define (process-import/export spec res bind?) + (define (process-import/export spec res bind? add-prefix) (syntax-case spec (only except prefix rename) (_ (identifier? spec) - (do-identifier spec res bind?)) + (do-identifier spec res bind? add-prefix)) ((only sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) - (lambda (x) x) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) + (lambda (id) id) (lambda (id) (car (generate-temporaries #`(#,id)))))) ((except sub-spec id ...) - (do-only/except (process-import/export #'sub-spec res bind?) - (syntax->list #'(id ...)) + (do-only/except (process-import/export #'sub-spec res bind? add-prefix) + (add-prefixes add-prefix #'(id ...)) (lambda (id) (car (generate-temporaries #`(#,id)))) - (lambda (x) x))) + (lambda (id) id))) ((prefix pid sub-spec) - (do-prefix (process-import/export #'sub-spec res bind?) #'pid)) + (process-import/export #'sub-spec res bind? + (lambda (id) + (do-prefix (add-prefix id) #'pid)))) ((rename sub-spec (internal external) ...) (let* ((sig-res - (do-rename (process-import/export #'sub-spec res bind?) + (do-rename (process-import/export #'sub-spec res bind? add-prefix) #'(internal ...) - #'(external ...))) + (datum->syntax-object #f (add-prefixes add-prefix #'(external ...))))) (dup (check-duplicate-identifier (sig-int-names sig-res)))) (when dup (raise-stx-err @@ -353,7 +354,7 @@ ;; process-spec : syntax-object -> sig (define (process-spec spec) (check-tagged-spec-syntax spec #f identifier?) - (process-import/export spec (box #f) #t)) + (process-import/export spec (box #f) #t values)) ; ;; extract-siginfo : (union import-spec export-spec) -> ??? diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 60072b633c..593155f322 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -126,8 +126,7 @@ ((((int-sid . ext-sid) ...) . sbody) ...)) (map-sig (lambda (x) x) (make-syntax-introducer) - sig) - #;(add-context-to-sig sig)]) + sig)]) (list #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) (values @@ -329,13 +328,6 @@ 'expression (list #'stop) def-ctx)))) - - (define-for-syntax (add-context-to-sig sig) - (let ((def-ctx (syntax-local-make-definition-context))) - (syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx) - (map-sig (lambda (x) x) - (lambda (x) (localify x def-ctx)) - sig))) (define-for-syntax (iota n) (let loop ((n n) @@ -619,6 +611,7 @@ [_ (void)])) expanded-body) table)]) + (internal-definition-context-seal def-ctx) ;; Mark exported names and ;; check that all exported names are defined (as var): diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss index 9952cebe62..c3cdbb6d0a 100644 --- a/collects/mzlib/unit200.ss +++ b/collects/mzlib/unit200.ss @@ -158,7 +158,10 @@ [else (list defn-or-expr)]))) defns&exprs))) values)]) + (let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))]) + (when def-ctx + (internal-definition-context-seal def-ctx)) ;; Get all the defined names, sorting out variable definitions ;; from syntax definitions. (let* ([definition? diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index ec3205135a..8c166179c2 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -410,6 +410,7 @@ (cdr exprs))) (reverse idss) (reverse rhss) (reverse stx-idss) (reverse stx-rhss))]))))]) + (internal-definition-context-seal def-ctx) (if (and (null? (syntax-e #'(stx-rhs ...))) (andmap (lambda (ids) (= 1 (length (syntax->list ids)))) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 537431549d..b34ce1cf94 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "24nov2008") +#lang scheme/base (provide stamp) (define stamp "25nov2008") diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss new file mode 100644 index 0000000000..9667509e30 --- /dev/null +++ b/collects/scheme/package.ss @@ -0,0 +1,394 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/kerncase + syntax/boundmap + syntax/define)) + +(provide define-package + package-begin + + open-package + open*-package + + define* + define*-values + define*-syntax + define*-syntaxes) + +(define-for-syntax (do-define-* stx define-values-id) + (syntax-case stx () + [(_ (id ...) rhs) + (let ([ids (syntax->list #'(id ...))]) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "expected an identifier for definition" + stx + id))) + ids) + (with-syntax ([define-values define-values-id]) + (syntax/loc stx + (define-values (id ...) rhs))))])) +(define-syntax (define*-values stx) + (do-define-* stx #'define-values)) +(define-syntax (define*-syntaxes stx) + (do-define-* stx #'define-syntaxes)) + +(define-syntax (define* stx) + (let-values ([(id rhs) (normalize-definition stx #'lambda)]) + (quasisyntax/loc stx + (define*-values (#,id) #,rhs)))) +(define-syntax (define*-syntax stx) + (let-values ([(id rhs) (normalize-definition stx #'lambda)]) + (quasisyntax/loc stx + (define*-syntaxes (#,id) #,rhs)))) + +(begin-for-syntax + (define-struct package (exports hidden) + #:omit-define-syntaxes + #:property prop:procedure (lambda (r stx) + (raise-syntax-error + #f + "misuse of a package name" + stx))) + + (define (reverse-mapping who id exports hidden) + (or (ormap (lambda (m) + (and (free-identifier=? id (cdr m)) + (car m))) + exports) + (ormap (lambda (h) + (and (free-identifier=? id h) + ;; Not at top level, where free-id=? is unreliable, + ;; and re-definition is ok: + (identifier-binding id) + ;; Name is inaccessible. Generate a temporary to + ;; avoid potential duplicate-definition errors + ;; when the name is bound in the same context as + ;; the package. + (car (generate-temporaries (list id))))) + hidden) + id))) + +(define-for-syntax (do-define-package stx exp-stx) + (syntax-case exp-stx () + [(_ pack-id mode exports form ...) + (let ([id #'pack-id] + [exports #'exports] + [mode (syntax-e #'mode)]) + (unless (eq? mode '#:begin) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier" + stx + id))) + (let ([exports + (cond + [(syntax->list exports) + => (lambda (l) + (for-each (lambda (i) + (unless (identifier? i) + (raise-syntax-error #f + "expected identifier to export" + stx + i))) + l) + (let ([dup-id (check-duplicate-identifier l)]) + (when dup-id + (raise-syntax-error + #f + "duplicate export" + stx + dup-id))) + l)] + [else (raise-syntax-error #f + (format "expected a parenthesized sequence of identifiers ~a" + (case mode + [(#:only) "to export"] + [(#:all-defined-except) "to exclude from export"] + [else (format "for ~a" mode)])) + stx + exports)])]) + (let* ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [pre-package-id (lambda (id def-ctxes) + (for/fold ([id id]) + ([def-ctx (in-list def-ctxes)]) + (identifier-remove-from-definition-context + id + def-ctx)))] + [kernel-forms (list* + #'define*-values + #'define*-syntaxes + (kernel-form-identifier-list))] + [init-exprs (syntax->list #'(form ...))] + [new-bindings (make-bound-identifier-mapping)] + [fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes) + (lambda (stx) + (syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax + list cons #%plain-lambda) + free-transformer-identifier=? + [(define-syntaxes (pack-id) + (#%plain-app + make-package + (#%plain-lambda () + (#%plain-app list + (#%plain-app cons + (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden)) + (with-syntax ([(export ...) + (map (lambda (id) + (if (or (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-exports) + (not (ormap (lambda (e-id) + (bound-identifier=? id e-id)) + renamed-defines))) + ;; Need to preserve the original + (pre-package-id id def-ctxes) + ;; It's not accessible, so just hide the name + ;; to avoid re-binding errors. + (car (generate-temporaries (list id))))) + (syntax->list #'(export ...)))]) + (syntax/loc stx + (define-syntaxes (pack-id) + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + hidden))))] + [_ stx])))] + [complement (lambda (bindings ids) + (let ([tmp (make-bound-identifier-mapping)]) + (bound-identifier-mapping-for-each bindings + (lambda (k v) + (bound-identifier-mapping-put! tmp k #t))) + (for-each (lambda (id) + (bound-identifier-mapping-put! tmp id #f)) + ids) + (filter + values + (bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))]) + (let ([register-bindings! + (lambda (ids) + (for-each (lambda (id) + (when (bound-identifier-mapping-get new-bindings id (lambda () #f)) + (raise-syntax-error #f + "duplicate binding" + stx + id)) + (bound-identifier-mapping-put! new-bindings + id + #t)) + ids))] + [add-package-context (lambda (def-ctxes) + (lambda (stx) + (for/fold ([stx stx]) + ([def-ctx (in-list (reverse def-ctxes))]) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx])))))]) + (let loop ([exprs init-exprs] + [rev-forms null] + [defined null] + [def-ctxes (list def-ctx)]) + (cond + [(null? exprs) + (for-each (lambda (def-ctx) + (internal-definition-context-seal def-ctx)) + def-ctxes) + (let ([exports-renamed (map (add-package-context def-ctxes) exports)] + [defined-renamed (bound-identifier-mapping-map new-bindings + (lambda (k v) k))]) + (for-each (lambda (ex renamed) + (unless (bound-identifier-mapping-get new-bindings + renamed + (lambda () #f)) + (raise-syntax-error #f + (format "no definition for ~a identifier" + (case mode + [(#:only) "exported"] + [(#:all-defined-except) "excluded"])) + stx + ex))) + exports + exports-renamed) + (let-values ([(exports exports-renamed) + (if (memq mode '(#:only #:begin)) + (values exports exports-renamed) + (let ([all-exports-renamed (complement new-bindings exports-renamed)]) + ;; In case of define*, get only the last definition: + (let ([tmp (make-bound-identifier-mapping)]) + (for-each (lambda (id) + (bound-identifier-mapping-put! + tmp + ((add-package-context def-ctxes) + (pre-package-id id def-ctxes)) + #t)) + all-exports-renamed) + (let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))] + [exports (map (lambda (id) (pre-package-id id def-ctxes)) + exports-renamed)]) + (values exports exports-renamed)))))]) + (with-syntax ([(export ...) exports] + [(renamed ...) exports-renamed] + [(hidden ...) (complement new-bindings exports-renamed)]) + (let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes) + (reverse rev-forms))]) + (if (eq? mode '#:begin) + (if (eq? 'expression (syntax-local-context)) + (quasisyntax/loc stx (let () #,@body)) + (quasisyntax/loc stx (begin #,@body))) + (quasisyntax/loc stx + (begin + #,@(if (eq? 'top-level (syntax-local-context)) + ;; delcare all bindings before they are used: + #`((define-syntaxes #,defined-renamed (values))) + null) + #,@body + (define-syntax pack-id + (make-package + (lambda () + (list (cons (quote-syntax export) + (quote-syntax renamed)) + ...)) + (lambda () + (list (quote-syntax hidden) ...)))))))))))] + [else + (let ([expr ((add-package-context (cdr def-ctxes)) + (local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) + ctx + kernel-forms + (car def-ctxes)))]) + (syntax-case expr (begin) + [(begin . rest) + (loop (append (syntax->list #'rest) (cdr exprs)) + rev-forms + defined + def-ctxes)] + [(def (id ...) rhs) + (and (or (free-identifier=? #'def #'define-syntaxes) + (free-identifier=? #'def #'define*-syntaxes)) + (andmap identifier? (syntax->list #'(id ...)))) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (let ([star? (free-identifier=? #'def #'define*-syntaxes)] + [ids (syntax->list #'(id ...))]) + (let* ([def-ctx (if star? + (syntax-local-make-definition-context) + (car def-ctxes))] + [ids (if star? + (map (add-package-context (list def-ctx)) ids) + ids)]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons #`(define-syntaxes #,ids rhs) + rev-forms) + (cons ids defined) + (if star? (cons def-ctx def-ctxes) def-ctxes)))))] + [(def (id ...) rhs) + (and (or (free-identifier=? #'def #'define-values) + (free-identifier=? #'def #'define*-values)) + (andmap identifier? (syntax->list #'(id ...)))) + (let ([star? (free-identifier=? #'def #'define*-values)] + [ids (syntax->list #'(id ...))]) + (let* ([def-ctx (if star? + (syntax-local-make-definition-context) + (car def-ctxes))] + [ids (if star? + (map (add-package-context (list def-ctx)) ids) + ids)]) + (syntax-local-bind-syntaxes ids #f def-ctx) + (register-bindings! ids) + (loop (cdr exprs) + (cons #`(define-values #,ids rhs) rev-forms) + (cons ids defined) + (if star? (cons def-ctx def-ctxes) def-ctxes))))] + [else + (loop (cdr exprs) + (cons (if (and (eq? mode '#:begin) + (null? (cdr exprs))) + expr + #`(define-values () (begin #,expr (values)))) + rev-forms) + defined + def-ctxes)]))]))))))])) + +(define-syntax (define-package stx) + (syntax-case stx () + [(_ id #:all-defined form ...) + (do-define-package stx #'(define-package id #:all-defined () form ...))] + [(_ id #:all-defined-except ids form ...) + (do-define-package stx stx)] + [(_ id #:only ids form ...) + (do-define-package stx stx)] + [(_ id ids form ...) + (do-define-package stx #'(define-package id #:only ids form ...))])) + +(define-syntax (package-begin stx) + (syntax-case stx () + [(_ form ...) + (do-define-package stx #'(define-package #f #:begin () form ...))])) + +(define-for-syntax (do-open stx define-syntaxes-id) + (syntax-case stx () + [(_ pack-id) + (let ([id #'pack-id]) + (unless (identifier? id) + (raise-syntax-error #f + "expected an identifier for a package" + stx + id)) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (package? v) + (raise-syntax-error #f + "identifier is not bound to a package" + stx + id)) + (let ([introduce (syntax-local-make-delta-introducer + (syntax-local-introduce id))]) + (with-syntax ([(intro ...) + (map (lambda (i) + (syntax-local-introduce + (syntax-local-get-shadower + (introduce i)))) + (map car ((package-exports v))))] + [(defined ...) + (map (lambda (v) (syntax-local-introduce (cdr v))) + ((package-exports v)))] + [((a . b) ...) (map (lambda (p) + (cons (syntax-local-introduce (car p)) + (syntax-local-introduce (cdr p)))) + ((package-exports v)))] + [(h ...) (map syntax-local-introduce ((package-hidden v)))]) + #`(begin + (#,define-syntaxes-id (intro ...) + (let ([rev-map (lambda (x) + (reverse-mapping + 'pack-id + x + (list (cons (quote-syntax a) + (quote-syntax b)) + ...) + (list (quote-syntax h) ...)))]) + (values (make-rename-transformer #'defined rev-map) + ...))))))))])) + +(define-syntax (open-package stx) + (do-open stx #'define-syntaxes)) +(define-syntax (open*-package stx) + (do-open stx #'define*-syntaxes)) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 36356c5413..37006a569d 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -1214,6 +1214,8 @@ proc)))))) methods)))] [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) + + (internal-definition-context-seal def-ctx) ;; ---- build final result ---- (with-syntax ([public-names (map lookup-localize-cdr publics)] diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 7124f054be..23eb987652 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -52,6 +52,7 @@ (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) (let* ([add-context (lambda (expr) (let ([q (local-expand #`(quote #,expr) diff --git a/collects/scribblings/reference/package.scrbl b/collects/scribblings/reference/package.scrbl new file mode 100644 index 0000000000..1305de688a --- /dev/null +++ b/collects/scribblings/reference/package.scrbl @@ -0,0 +1,119 @@ +#lang scribble/doc +@(require "mz.ss" + (for-label scheme/package)) + +@(define pack-eval (make-base-eval)) +@interaction-eval[#:eval pack-eval (require scheme/package)] + +@title[#:tag "package"]{Limiting Scope: @scheme[define-package], @scheme[open-package], ...} + +@note-lib-only[scheme/package] + +@deftogether[( +@defform[(define-package package-id exports form ...)] +@defform/subs[(open-package package-id) + ([exports (id ...) + (code:line #:only (id ...)) + #:all-defined + (code:line #:all-defined-except (id ...))])] +)]{ + +The @scheme[define-package] form is similar to @scheme[module], except +that it can appear in any definition context. The @scheme[form]s +within a @scheme[define-package] form can be definitions or +expressions; definitions are not visible outside the +@scheme[define-package] form, but @scheme[exports] determines a subset +of the bindings that can be made visible outside the package using +the definition form @scheme[(open-package package-id)]. + +The @scheme[(id ...)] and @scheme[#:only (id ...)] @scheme[exports] +forms are equivalent: exactly the listed @scheme[id]s are +exported. The @scheme[#:all-defined] form exports all definitions from +the package body, and @scheme[#:all-defined-except (id ...)] exports +all definitions except the listed @scheme[id]s. + +All of the usual definition forms work within a +@scheme[define-package] body, and such definitions are visible to all +expressions within the body (and, in particular, the definitions can +refer to each other). However, @scheme[define-package] handles +@scheme[define*], @scheme[define*-syntax], @scheme[define*-values], +@scheme[define*-syntaxes], and +@scheme[open*-syntaxes] specially: the bindings introduced by those +forms within a @scheme[define-package] body are visible only to +@scheme[form]s that appear later in the body, and they can shadow any +binding from preceding @scheme[form]s (even if the preceding binding +did not use one of the special @schemeidfont[*] definition forms). If +an exported identifier is defined multiple times, the last definition +is the exported one. + +@examples[ +#:eval pack-eval +(define-package presents (doll) + (define doll "Molly Coddle") + (define robot "Destructo")) +doll +robot +(open-package presents) +doll +robot +(define-package big-russian-doll (middle-russian-doll) + (define-package middle-russian-doll (little-russian-doll) + (define little-russian-doll "Anastasia"))) +(open-package big-russian-doll) +(open-package middle-russian-doll) +little-russian-doll +]} + + +@defform[(package-begin form ...)]{ + +Similar to @scheme[define-package], but it only limits the visible of +definitions without binding a package name. If the last @scheme[form] +is an expression, then the expression is in @tech{tail position} for +the @scheme[package-begin] form, so that its result is the +@scheme[package-begin] result. + +A @scheme[package-begin] form can be used as an expression, but if it +is used in a context where definitions are allowed, then the +definitions are essentially spliced into the enclosing context (though +the defined bindings remain hidden outside the +@scheme[package-begin]). + +@examples[ +#:eval pack-eval +(package-begin + (define secret "mimi") + (list secret)) +secret +]} + +@deftogether[( +@defidform[define*] +@defidform[define*-values] +@defidform[define*-syntax] +@defidform[define*-syntaxes] +@defidform[open*-package] +)]{ + +Equivalent to @scheme[define], @scheme[define-values], +@scheme[define-syntax], @scheme[define-syntaxes], +and @scheme[open-package], except within a +@scheme[define-package] or @scheme[package-begin] form, where they +create bindings that are visible only to later body forms. + +@examples[ +#:eval pack-eval +(define-package mail (cookies) + (define* cookies (list 'sugar)) + (define* cookies (cons 'chocolate-chip cookies))) +(open-package mail) +cookies +(define-syntax-rule (define-seven id) (define id 7)) +(define-syntax-rule (define*-seven id) + (begin + (define-package p (id) (define-seven id)) + (open*-package p))) +(package-begin + (define vii 8) + (define*-seven vii) + vii)]} diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index eea79141e9..97df718550 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -312,10 +312,13 @@ byte strings corresponding to a sequence of matches of results for parenthesized sub-patterns in @scheme[pattern] are not returned.) -If @scheme[pattern] matches a zero-length string or byte sequence, and -if it is at the beginning or end of the input, then the match does not -count. Otherwise, one character or byte in the input is skipped before -attempting another match. +The @scheme[pattern] is used in order to find matches, where each +match attempt starts at the end of the last match. Empty matches are +handled like any matches, returning a zero-length string or byte +sequence (they are more useful in the complementing +@scheme[regexp-split] function). However, the @scheme[pattern] is +restricted from matching an empty string at the beginning (or right +after a previous match) or at the end. If @scheme[input] contains no matches (in the range @scheme[start-pos] to @scheme[end-pos]), @scheme[null] is returned. Otherwise, each item @@ -525,7 +528,7 @@ strings (if @scheme[pattern] is a string or character regexp and @scheme[input] that are separated by matches to @scheme[pattern]. Adjacent matches are separated with @scheme[""] or @scheme[#""]. Zero-length matches are treated the same as in -@scheme[regexp-match*]. +@scheme[regexp-match*], but are more useful in this case. If @scheme[input] contains no matches (in the range @scheme[start-pos] to @scheme[end-pos]), the result is a list containing @scheme[input]'s @@ -539,8 +542,11 @@ case splitting goes to the end of @scheme[input] (which corresponds to an end-of-file if @scheme[input] is an input port). @examples[ -(regexp-split #rx"x" "12x4x6") -(regexp-split #rx"." "12x4x6") +(regexp-split #rx" +" "12 34") +(regexp-split #rx"." "12 34") +(regexp-split #rx"" "12 34") +(regexp-split #rx" *" "12 34") +(regexp-split #px"\\b" "12, 13 and 14.") ]} @;------------------------------------------------------------------------ diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 4ef99b1666..f05aad24f3 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -58,15 +58,19 @@ Returns the procedure that was passed to @scheme[make-set!-transformer] to create @scheme[transformer].} -@defproc[(make-rename-transformer [id-stx syntax?]) +@defproc[(make-rename-transformer [id-stx syntax?] + [delta-introduce (identifier? . -> . identifier?) + (lambda (id) id)]) rename-transformer?]{ -Creates a value that, when used as a @tech{transformer binding}, -inserts the identifier @scheme[id-stx] in place of whatever identifier -binds the transformer, including in non-application positions, and in +Creates a @tech{rename transformer} that, when used as a +@tech{transformer binding}, acts as a transformer that insert the +identifier @scheme[id-stx] in place of whatever identifier binds the +transformer, including in non-application positions, and in @scheme[set!] expressions. Such a transformer could be written manually, but the one created by @scheme[make-rename-transformer] -cooperates specially with @scheme[syntax-local-value] (see below).} +cooperates specially with @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer].} @defproc[(rename-transformer? [v any/c]) boolean?]{ @@ -184,15 +188,25 @@ expressions are reported as @scheme[define-values] forms (in the transformer environment).} +@defproc[(internal-definition-context? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is an @tech{internal-definition +context}, @scheme[#f] otherwise.} + + @defproc[(syntax-local-make-definition-context) internal-definition-context?]{ -Creates an opaque internal-definition context value to be used with -@scheme[local-expand] and other functions. A transformer should create -one context for each set of internal definitions to be expanded, and -use it when expanding any form whose lexical context should include -the definitions. After discovering an internal @scheme[define-values] -or @scheme[define-syntaxes] form, use +Creates an opaque @tech{internal-definition context} value to be used +with @scheme[local-expand] and other functions. A transformer should +create one context for each set of internal definitions to be +expanded, and use it when expanding any form whose lexical context +should include the definitions. After discovering an internal +@scheme[define-values] or @scheme[define-syntaxes] form, use @scheme[syntax-local-bind-syntaxes] to add bindings to the context. +Finally, the transformer must call +@scheme[internal-definition-context-seal] after all bindings have been +added; if an unsealed @tech{internal-definition context} is detected +in a fully expanded expression, the @exnraise[exn:fail:contract]. @transform-time[]} @@ -203,7 +217,7 @@ or @scheme[define-syntaxes] form, use void?]{ Binds each identifier in @scheme[id-list] within the -internal-definition context represented by @scheme[intdef-ctx], where +@tech{internal-definition context} represented by @scheme[intdef-ctx], where @scheme[intdef-ctx] is the result of @scheme[syntax-local-make-definition-context]. Supply @scheme[#f] for @scheme[expr] when the identifiers correspond to @@ -216,6 +230,24 @@ match the number of identifiers, otherwise the @transform-time[]} +@defproc[(internal-definition-context-seal [intdef-ctx internal-definition-context?]) + void?]{ + +Indicates that no further bindings will be added to +@scheme[intdef-ctx], which must not be sealed already. See also +@scheme[syntax-local-make-definition-context].} + + +@defproc[(identifier-remove-from-defininition-context [id-stx identifier?] + [intdef-ctx internal-definition-context?]) + identifier?]{ + +Removes @scheme[intdef-ctx] from the @tech{lexical information} of +@scheme[id-stx]. This operation is useful for correlating an identifier +that is bound in an internal-definition context with its binding +before the internal-definition context was created.} + + @defproc[(syntax-local-value [id-stx syntax?] [failure-thunk (or/c (-> any) #f) #f] @@ -225,16 +257,16 @@ match the number of identifiers, otherwise the any]{ Returns the @tech{transformer binding} value of @scheme[id-stx] in -either the context asscoiated with @scheme[intdef-ctx] (if not +either the context associated with @scheme[intdef-ctx] (if not @scheme[#f]) or the context of the expression being expanded (if @scheme[indef-ctx] is @scheme[#f]). If @scheme[intdef-ctx] is provided, it must be an extension of the context of the expression being expanded. -If @scheme[id-stx] is bound to a rename transformer created with -@scheme[make-rename-transformer], @scheme[syntax-local-value] +If @scheme[id-stx] is bound to a @tech{rename transformer} created +with @scheme[make-rename-transformer], @scheme[syntax-local-value] effectively calls itself with the target of the rename and returns -that result, instead of the rename transformer. +that result, instead of the @tech{rename transformer}. If @scheme[id-stx] has no @tech{transformer binding} (via @scheme[define-syntax], @scheme[let-syntax], etc.) in that @@ -333,8 +365,8 @@ context}. The identity of the lists's first element (i.e., its @scheme[eq?]ness) reflects the identity of the internal-definition context; in particular two transformer expansions receive the same first value if and only if they are invoked for the same -internal-definition context. Later values in the list similarly -identify internal-definition contexts that are still being expanded, +@tech{internal-definition context}. Later values in the list similarly +identify @tech{internal-definition contexts} that are still being expanded, and that required the expansion of nested internal-definition contexts. @@ -440,20 +472,53 @@ mark}. Multiple applications of the same @scheme[make-syntax-introducer] result procedure use the same mark, and different result procedures use distinct marks.} -@defproc[(make-syntax-delta-introducer [ext-stx syntax?] [base-stx syntax?]) +@defproc[(make-syntax-delta-introducer [ext-stx syntax?] + [base-stx syntax?] + [phase-level (or/c #f exact-integer?) + (syntax-local-phase-level)]) (syntax? . -> . syntax?)]{ Produces a procedure that behaves like -@scheme[syntax-local-introduce], but using the @tech{syntax -marks} of @scheme[ext-stx] that are not shared with @scheme[base-stx]. +@scheme[syntax-local-introduce], but using the @tech{syntax marks} of +@scheme[ext-stx] that are not shared with @scheme[base-stx]. If +@scheme[ext-stx] does not extend the set of marks in @scheme[base-stx] +but @scheme[ext-stx] has a module binding in the @tech{phase level} +indicated by @scheme[phase-level], then any marks of @scheme[ext-stx] +that would be needed to preserve its binding are not transferred in an +introduction. -This procedure is useful when @scheme[_m-id] has a transformer binding -that records some @scheme[_orig-id], and a use of @scheme[_m-id] -introduces a binding of @scheme[_orig-id]. In that case, the -@tech{syntax marks} in the use of @scheme[_m-id] since the binding of -@scheme[_m-id] should be transferred to the binding instance of -@scheme[_orig-id], so that it captures uses with the same lexical -context as the use of @scheme[_m-id].} +This procedure is potentially useful when @scheme[_m-id] has a +transformer binding that records some @scheme[_orig-id], and a use of +@scheme[_m-id] introduces a binding of @scheme[_orig-id]. In that +case, the @tech{syntax marks} in the use of @scheme[_m-id] since the +binding of @scheme[_m-id] should be transferred to the binding +instance of @scheme[_orig-id], so that it captures uses with the same +lexical context as the use of @scheme[_m-id]. + +More typically, however, @scheme[syntax-local-make-delta-introducer] +should be used, since it cooperates with @tech{rename transformers}.} + +@defproc[(syntax-local-make-delta-introducer [id identifier?]) + (identifier? . -> . identifier?)]{ + +Determines the binding of @scheme[id]. If the binding is not a +@tech{rename transformer}, the result is an introducer as created by +@scheme[make-syntax-delta-introducer] using @scheme[id] and the +binding of @scheme[id] in the environment of expansion. If the binding +is a @tech{rename transformer}, then the introducer is one composed +with the target of the @tech{rename transformer} and its +binding. Furthermore, the @scheme[_delta-introduce] functions +associated with the @tech{rename transformers} (supplied as the second +argument to @scheme[make-rename-transformer]) are composed (in +first-to-last order) before the introducers created with +@scheme[make-syntax-delta-introducer] (which are composed +last-to-first). + +The @exnraise[exn:fail:contract] if @scheme[id] or any identifier in +its rename-transformer chain has no binding. + +@transform-time[]} + @defproc[(syntax-local-transforming-module-provides?) boolean?]{ diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 79220ca738..dfa0d2bf55 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -543,8 +543,9 @@ transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by @scheme[make-rename-transformer], it is replaced with the identifier passed to @scheme[make-rename-transformer]. Furthermore, the binding -is also specially handled by @scheme[syntax-local-value] as used by -@tech{syntax transformer}s. +is also specially handled by @scheme[syntax-local-value] and +@scheme[syntax-local-make-delta-introducer] as used by @tech{syntax +transformer}s. In addition to using marks to track introduced identifiers, the expander tracks the expansion history of a form through @tech{syntax diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index ec899647fe..d55fdc6aef 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -9,7 +9,8 @@ make-provide-transformer) scheme/provide-syntax scheme/provide - scheme/nest)) + scheme/nest + scheme/package)) @(define cvt (schemefont "CVT")) @@ -68,10 +69,13 @@ Within such specifications, @defform[(module id module-path form ...)]{ -Declares a module. If the @scheme[current-module-declare-name] -parameter is set, the parameter value is used for the module name, -otherwise @scheme[(#,(scheme quote) id)] is the name of the declared -module. +Declares a top-level module. If the +@scheme[current-module-declare-name] parameter is set, the parameter +value is used for the module name, otherwise @scheme[(#,(scheme quote) +id)] is the name of the declared module. + +@margin-note/ref{For a @scheme[module]-like form for use @emph{within} +modules and other contexts, see @scheme[define-package].} The @scheme[module-path] must be as for @scheme[require], and it supplies the initial bindings for the body @scheme[form]s. That is, it @@ -1931,6 +1935,9 @@ provides a hook to control interactive evaluation through @scheme[load] (more precisely, the default @tech{load handler}) or @scheme[read-eval-print-loop].} +@;------------------------------------------------------------------------ +@include-section["package.scrbl"] + @;------------------------------------------------------------------------ @section[#:tag "nest"]{Flattening Syntactic Sequences: @scheme[nest]} diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 4080b105b7..5c9b022a05 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -214,7 +214,7 @@ (arity-test make-set!-transformer 1 1) (arity-test set!-transformer? 1 1) -(arity-test make-rename-transformer 1 1) +(arity-test make-rename-transformer 1 2) (arity-test rename-transformer? 1 1) ;; Test inheritance of context when . is used in a pattern @@ -400,4 +400,36 @@ ;; ---------------------------------------- +(define-syntax (bind stx) + (syntax-case stx () + [(_ handle def) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))] + [kernel-forms (list #'define-values)]) + (let ([def (local-expand #'def ctx kernel-forms def-ctx)]) + (syntax-case def () + [(define-values (id) rhs) + (begin + (syntax-local-bind-syntaxes (list #'id) #f def-ctx) + #'(begin + (define-values (id) rhs) + (define-syntax handle (quote-syntax id))))] + [_ (error "no")])))])) + +(define-syntax (nab stx) + (syntax-case stx () + [(_ handle) + (syntax-local-value #'handle)])) + +(let () + (bind h (define q 5)) + (define q 8) + (nab h)) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls index d39521ad9e..50bcf669e6 100644 --- a/collects/tests/r6rs/base.sls +++ b/collects/tests/r6rs/base.sls @@ -72,6 +72,10 @@ (syntax-rules () [(_ [str num] ...) (begin (test (string->number str) num) ...)])) + (define-syntax test/approx-string-to-number + (syntax-rules () + [(_ [str num] ...) (begin (test/approx (string->number str) num) ...)])) + ;; Definitions ---------------------------------------- (define add3 @@ -968,7 +972,9 @@ ("#e1e1000" (expt 10 1000)) ("#e-1e1000" (- (expt 10 1000))) ("#e1e-1000" (expt 10 -1000)) - ("#e-1e-1000" (- (expt 10 -1000))) + ("#e-1e-1000" (- (expt 10 -1000)))) + + (test/approx-string-to-number ("#i1e100" (inexact (expt 10 100))) ("#i1e1000" (inexact (expt 10 1000))) ("#i-1e1000" (inexact (- (expt 10 1000)))) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 72513d6336..2df9b00213 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -37,6 +37,7 @@ [require "match/plt-match-tests.ss"] ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] + [require "scribble/main.ss"] )) diff --git a/collects/tests/units/test-unit.ss b/collects/tests/units/test-unit.ss index e7cb92bc2c..2dd639d3b2 100644 --- a/collects/tests/units/test-unit.ss +++ b/collects/tests/units/test-unit.ss @@ -1644,12 +1644,16 @@ (define-signature sig^ (u-a)) -(define unit@ - (unit - (import) - (export sig^) +(define-unit unit@ + (import) + (export sig^) + + (define u-a 'zero)) - (define u-a 'zero))) +(test 'zero + (let ([q:u-a 5]) + (define-values/invoke-unit unit@ (import) (export (prefix q: sig^))) + q:u-a)) (define-syntax (use-unit stx) (syntax-case stx () @@ -1658,6 +1662,13 @@ (define-values/invoke-unit unit@ (import) (export sig^)) u-a)])) +(define-syntax (use-unit2 stx) + (syntax-case stx () + [(_) + #'(let () + (define-values/invoke-unit/infer unit@) + u-a)])) + (define-syntax (use-unit-badly1 stx) (syntax-case stx () [(_ u-a) @@ -1673,6 +1684,7 @@ u-a)])) (test 'zero (use-unit)) +(test 'zero (use-unit2)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" (use-unit-badly1 u-a)) (test-runtime-error exn:fail:contract:variable? "context mismatch; no u-a" diff --git a/collects/web-server/scribblings/templates.scrbl b/collects/web-server/scribblings/templates.scrbl index e04d3dbd06..2070236f00 100644 --- a/collects/web-server/scribblings/templates.scrbl +++ b/collects/web-server/scribblings/templates.scrbl @@ -286,56 +286,111 @@ the template to be unescaped, then create a @scheme[cdata] structure: @section{Conversion Example} -Alonzo Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates]. +Al Church has been maintaining a blog with PLT Scheme for some years and would like to convert to @schememodname[web-server/templates]. -Here's the code he starts off with: -@schememod[ - scheme -(require xml - web-server/servlet - web-server/servlet-env) - -(code:comment "He actually Church-encodes them, but we'll use structs.") -(define-struct post (title body comments)) +The data-structures he uses are defined as: +@schemeblock[ +(define-struct post (title body)) (define posts (list (make-post "(Y Y) Works: The Why of Y" - "..." - (list - "First post! - A.T." - "Didn't I write this? - Matthias")) + "Why is Y, that is the question.") (make-post "Church and the States" - "As you may know, I grew up in DC, not technically a state..." - (list - "Finally, A Diet That Really Works! As Seen On TV")))) + "As you may know, I grew up in DC, not technically a state."))) +] +Actually, Al Church-encodes these posts, but for explanatory reasons, we'll use structs. -(code:comment "A function that is the generic template for the site") +He has divided his code into presentation functions and logic functions. We'll look at the presentation functions first. + +The first presentation function defines the common layout of all pages. +@schemeblock[ (define (template section body) `(html - (head (title "Alonzo's Church: " ,section) - (style ([type "text/css"]) - (code:comment "CDATA objects were useful for returning raw data") - ,(make-cdata #f #f "\n body {\n margin: 0px;\n padding: 10px;\n }\n\n #main {\n background: #dddddd;\n }"))) + (head (title "Al's Church: " ,section)) (body - (script ([type "text/javascript"]) - (code:comment "Which is particularly useful for JavaScript") - ,(make-cdata #f #f "\n var gaJsHost = ((\"https:\" == document.location.protocol) ?\n \"https://ssl.\" : \"http://www.\");\n document.write(unescape(\"%3Cscript src='\" + gaJsHost +\n \"google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E\"));\n")) - (script ([type "text/javascript"]) - ,(make-cdata #f #f "\n var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");\n pageTracker._trackPageview();\n")) - - (h1 "Alonzo's Church: " ,section) + (h1 "Al's Church: " ,section) (div ([id "main"]) - (code:comment "He had to be careful to use splicing here") ,@body)))) +] +One of the things to notice here is the @scheme[unquote-splicing] on the @scheme[body] argument. +This indicates that the @scheme[body] is list of @|xexpr|s. If he had accidentally used only @scheme[unquote] +then there would be an error in converting the return value to an HTTP response. + +@schemeblock[ (define (blog-posted title body k-url) `((h2 ,title) (p ,body) (h1 (a ([href ,k-url]) "Continue")))) +] +Here's an example of simple body that uses a list of @|xexpr|s to show the newly posted blog entry, before continuing to redisplay +the main page. Let's look at a more complicated body: + +@schemeblock[ +(define (blog-posts k-url) + (append + (apply append + (for/list ([p posts]) + `((h2 ,(post-title p)) + (p ,(post-body p))))) + `((h1 "New Post") + (form ([action ,k-url]) + (input ([name "title"])) + (input ([name "body"])) + (input ([type "submit"])))))) +] + +This function shows a number of common patterns that are required by @|xexpr|s. First, @scheme[append] is used to combine +different @|xexpr| lists. Second, @scheme[apply append] is used to collapse and combine the results of a @scheme[for/list] +where each iteration results in a list of @|xexpr|s. We'll see that these patterns are unnecessary with templates. Another +annoying patterns shows up when Al tries to add CSS styling and some JavaScript from Google Analytics to all the pages of +his blog. He changes the @scheme[template] function to: + +@schemeblock[ +(define (template section body) + `(html + (head + (title "Al's Church: " ,section) + (style ([type "text/css"]) + "body {margin: 0px; padding: 10px;}" + "#main {background: #dddddd;}")) + (body + (script + ([type "text/javascript"]) + ,(make-cdata + #f #f + "var gaJsHost = ((\"https:\" ==" + "document.location.protocol)" + "? \"https://ssl.\" : \"http://www.\");" + "document.write(unescape(\"%3Cscript src='\" + gaJsHost" + "+ \"google-analytics.com/ga.js' " + "type='text/javascript'%3E%3C/script%3E\"));")) + (script + ([type "text/javascript"]) + ,(make-cdata + #f #f + "var pageTracker = _gat._getTracker(\"UA-YYYYYYY-Y\");" + "pageTracker._trackPageview();")) + (h1 "Al's Church: " ,section) + (div ([id "main"]) + ,@body)))) +] + +@margin-note{Some of these problems go away by using here strings, as described in the documentation on + @secref[#:doc '(lib "scribblings/reference/reference.scrbl")]{parse-string}.} + +The first thing we notice is that encoding CSS as a string is rather primitive. Encoding JavaScript with strings is even worse for two +reasons: first, we are more likely to need to manually escape characters such as @"\""; second, we need to use a CDATA object, because most +JavaScript code uses characters that "need" to be escaped in XML, such as &, but most browsers will fail if these characters are +entity-encoded. These are all problems that go away with templates. + + +Before moving to templates, let's look at the logic functions: +@schemeblock[ (define (extract-post req) (define binds (request-bindings req)) @@ -344,30 +399,13 @@ Here's the code he starts off with: (define body (extract-binding/single 'body binds)) (set! posts - (list* (make-post title body empty) + (list* (make-post title body) posts)) (send/suspend (lambda (k-url) (template "Posted" (blog-posted title body k-url)))) (display-posts)) -(define (blog-posts k-url) - (code:comment "append or splicing is needed") - (append - (code:comment "Each element of the list is another list") - (apply append - (for/list ([p posts]) - `((h2 ,(post-title p)) - (p ,(post-body p)) - (ul - ,@(for/list ([c (post-comments p)]) - `(li ,c)))))) - `((h1 "New Post") - (form ([action ,k-url]) - (input ([name "title"])) - (input ([name "body"])) - (input ([type "submit"])))))) - (define (display-posts) (extract-post (send/suspend @@ -376,19 +414,29 @@ Here's the code he starts off with: (define (start req) (display-posts)) - -(serve/servlet start) ] -Luckily, Alonzo has great software engineering skills, so he's already separated the presentation logic into the functions -@scheme[blog-posted], @scheme[blog-posts], and @scheme[template]. Each one of these will turn into a different -template. +To use templates, we need only change @scheme[template], @scheme[blog-posted], and @scheme[blog-posts]: + +@schemeblock[ +(define (template section body) + (list TEXT/HTML-MIME-TYPE + (include-template "blog.html"))) + +(define (blog-posted title body k-url) + (include-template "blog-posted.html")) + +(define (blog-posts k-url) + (include-template "blog-posts.html")) +] + +Each of the templates are given below: @filepath{blog.html}: @verbatim[#:indent 2]|{ - Alonzo's Church: @|section| + Al's Church: @|section|