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

Merge branch 'master' of git:plt

Browse Source
This commit is contained in:
Matthias Felleisen 2010-10-04 18:22:26 -04:00
commit 70f4fdaada
27 changed files with 399 additions and 394 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/deinprogramm/deinprogramm-langs.rkt
View File

@ -1246,10 +1246,12 @@
;; test coverage
;;
;; WARNING: much code copied from "collects/lang/htdp-langs.rkt"
(define test-coverage-enabled (make-parameter #t))
(define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr)
(define (initialize-test-coverage-point expr)
(unless (thread-cell-ref current-test-coverage-info)
(let ([ht (make-hasheq)])
(thread-cell-set! current-test-coverage-info ht)
@ -1272,15 +1274,19 @@
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht
(hash-set! ht key (mcons #f expr)))))
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key)
(let ([ht (thread-cell-ref current-test-coverage-info)])
(and ht
(let ([v (hash-ref ht key)])
(and v
(with-syntax ([v v])
#'(set-mcar! v #t)))))))
(define (test-covered expr)
(let* ([ht (or (thread-cell-ref current-test-coverage-info)
(error 'deinprogramm-langs
"internal-error: no test-coverage table"))]
[v (hash-ref ht expr
(lambda ()
(error 'deinprogramm-langs
"internal-error: expression not found: ~.s"
expr)))])
#; (lambda () (set-box! v #t))
(with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))
(define-values/invoke-unit et:stacktrace@
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

35
collects/drracket/private/debug.rkt
View File

@ -925,7 +925,7 @@ profile todo:
(define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr)
(define (initialize-test-coverage-point expr)
(unless (hash? (thread-cell-ref current-test-coverage-info))
(let ([rep (drracket:rep:current-rep)])
(when rep
@ -938,14 +938,14 @@ profile todo:
(when (hash? ht)
;; if rep isn't around, we don't do test coverage...
;; this can happen when check syntax expands, for example
(hash-set! ht key (mcons #f expr)))))
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key)
(define (test-covered expr)
(let ([ht (thread-cell-ref current-test-coverage-info)])
(and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point'
(let ([v (hash-ref ht key #f)])
(and v
(λ () (set-mcar! v #t)))))))
(let ([v (hash-ref ht expr #f)])
;; (and v (λ () (set-box! v #t)))
(and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))))
(define test-coverage-interactions-text<%>
(interface ()
@ -1075,7 +1075,6 @@ profile todo:
[locked-ht (make-hasheq)]
[already-frozen-ht (make-hasheq)]
[actions-ht (make-hash)]
[on/syntaxes (hash-map ht (λ (_ pr) pr))]
;; can-annotate : (listof (list boolean srcloc))
;; boolean is #t => code was run
@ -1083,17 +1082,17 @@ profile todo:
;; remove those that cannot be annotated
[can-annotate
(filter values
(map (λ (pr)
(let ([stx (mcdr pr)])
(and (syntax? stx)
(let ([src (syntax-source stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)])
(and pos
span
(send (get-defs) port-name-matches? src)
(list (mcar pr) (make-srcloc (get-defs) #f #f pos span)))))))
on/syntaxes))]
(hash-map ht
(λ (stx covered?)
(and (syntax? stx)
(let ([src (syntax-source stx)]
[pos (syntax-position stx)]
[span (syntax-span stx)])
(and pos
span
(send (get-defs) port-name-matches? src)
(list (mcar covered?)
(make-srcloc (get-defs) #f #f pos span))))))))]
;; filtered : (listof (list boolean srcloc))
;; remove redundant expressions

8
collects/errortrace/errortrace-lib.rkt
View File

@ -66,7 +66,7 @@
;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax -> (values syntax info)
;; test-coverage-point : syntax syntax integer -> (values syntax info)
;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled) (zero? phase))
@ -240,10 +240,8 @@
(with-syntax ([key (datum->syntax #f key (quote-syntax here))]
[expr expr]
[register-executed-once register-executed-once]);<- 3D!
(syntax
(begin
(register-executed-once 'key)
expr))))
#'(begin (register-executed-once 'key)
expr)))
expr))
(define (get-execute-counts)

32
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -418,27 +418,31 @@ be wrapped.}
Determines if the test coverage annotation is inserted into the code.
This parameter controls how compilation happens---it does not affect the
dynamic behavior of the already compiled code. If the parameter is set,
calls to @schemein[test-covered] are inserted into the code (and
code generated by @schemein[test-covered] are inserted into the code (and
@schemein[initialize-test-coverage-point] is called during compilation).
If not, no calls to test-covered are inserted.}
If not, no calls to @scheme[test-covered] code are inserted.}
@defproc[(test-covered (key any/c)) (or/c (-> void?) syntax? #f)]{
This is called during compilation of the program with a key value once
for each point with the key for that program point that was passed to
@defproc[(test-covered (stx any/c)) (or/c syntax? (-> void?) #f)]{
This is called during compilation of the program with an expression for
each point in the program that was passed to
@schemein[initialize-test-coverage-point].
If the result is @scheme[#f], this program point is not
instrumented. If the result is syntax, it is inserted into the code,
and if it is a thunk, the thunk is inserted into the code in an
application. In either case, the syntax or the thunk should register
that the relevant point was covered.}
If the result is @scheme[#f], this program point is not instrumented. If
the result is syntax, it is inserted into the code, and if it is a
thunk, the thunk is inserted into the code in an application (using the
thunk directly, as a 3D value). In either case, the syntax or the thunk
should register that the relevant point was covered.
@defproc[(initialize-test-coverage-point (key any/c) (stx any/c)) void?]{
Note: using a thunk tends to be slow. Current uses in the Racket code
will create a mutable pair in @scheme[initialize-test-coverage-point],
and @scheme[test-covered] returns syntax that will set its mcar. (This
makes the resulting overhead about 3 times smaller.)}
@defproc[(initialize-test-coverage-point (stx any/c)) void?]{
During compilation of the program, this function is called with each
sub-expression of the program. The first argument is a special key
used to identify this program point. The second argument is the
syntax of this program point.}
sub-expression of the program. The argument is the syntax of this program
point, which is usually used as a key to identify this program point.}
@defthing[profile-key any/c]{

129
collects/errortrace/stacktrace.rkt
View File

@ -10,7 +10,7 @@
(with-mark
test-coverage-enabled
test-covered
test-covered
initialize-test-coverage-point
profile-key
@ -73,33 +73,28 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test case coverage instrumenter
;; Test case coverage instrumenter
;; The next procedure is called by `annotate' and `annotate-top' to wrap
;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
;; The next procedure is called by `annotate' and `annotate-top' to wrap
;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax phase -> syntax
;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled)
(zero? phase)
(syntax-position expr))
(let* ([key (gensym 'test-coverage-point)])
(initialize-test-coverage-point key expr)
(let ([thunk (test-covered key)])
(cond
[(procedure? thunk)
(with-syntax ([body body]
[thunk thunk])
#'(begin (#%plain-app thunk) body))]
[(syntax? thunk)
(with-syntax ([body body]
[thunk thunk])
#'(begin thunk body))]
[else
body])))
body))
;; test-coverage-point : syntax syntax phase -> syntax
;; sets a test coverage point for a single expression
(define (test-coverage-point body expr phase)
(if (and (test-coverage-enabled)
(zero? phase)
(syntax-position expr))
(begin (initialize-test-coverage-point expr)
(let ([thunk (test-covered expr)])
(cond [(procedure? thunk)
(with-syntax ([body body] [thunk thunk])
#'(begin (#%plain-app thunk) body))]
[(syntax? thunk)
(with-syntax ([body body] [thunk thunk])
#'(begin thunk body))]
[else body])))
body))
@ -227,39 +222,32 @@
(let ([p (syntax-property orig 'method-arity-error)]
[p2 (syntax-property orig 'inferred-name)])
(let ([new (if p
(syntax-property new 'method-arity-error p)
new)])
(syntax-property new 'method-arity-error p)
new)])
(if p2
(syntax-property new 'inferred-name p2)
new))))
(define (annotate-let expr phase varss-stx rhss-stx bodys-stx)
(let ([varss (syntax->list varss-stx)]
[rhss (syntax->list rhss-stx)]
[rhss (syntax->list rhss-stx)]
[bodys (syntax->list bodys-stx)])
(let ([rhsl (map
(lambda (vars rhs)
(annotate-named
(syntax-case vars ()
[(id)
(syntax id)]
[_else #f])
(syntax-case vars () [(id) (syntax id)] [_else #f])
rhs
phase))
varss
rhss)]
[bodyl (map
(lambda (body)
(annotate body phase))
bodys)])
[bodyl (map (lambda (body) (annotate body phase))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl))))))
(define (annotate-seq expr bodys-stx annotate phase)
(let* ([bodys (syntax->list bodys-stx)]
[bodyl (map (lambda (b)
(annotate b phase))
bodys)])
[bodyl (map (lambda (b) (annotate b phase)) bodys)])
(rebuild expr (map cons bodys bodyl))))
(define orig-inspector (current-code-inspector))
@ -268,45 +256,30 @@
(syntax-recertify new orig orig-inspector #f))
(define (rebuild expr replacements)
(let loop ([expr expr]
[same-k (lambda () expr)]
[diff-k (lambda (x) x)])
(let loop ([expr expr] [same-k (lambda () expr)] [diff-k (lambda (x) x)])
(let ([a (assq expr replacements)])
(if a
(diff-k (cdr a))
(cond
[(pair? expr) (loop (car expr)
(lambda ()
(loop (cdr expr)
same-k
(lambda (y)
(diff-k (cons (car expr) y)))))
(lambda (x)
(loop (cdr expr)
(lambda ()
(diff-k (cons x (cdr expr))))
(lambda (y)
(diff-k (cons x y))))))]
[(vector? expr)
(loop (vector->list expr)
same-k
(lambda (x) (diff-k (list->vector x))))]
[(box? expr) (loop (unbox expr)
same-k
(lambda (x)
(diff-k (box x))))]
[(syntax? expr) (if (identifier? expr)
(same-k)
(loop (syntax-e expr)
same-k
(lambda (x)
(diff-k
(datum->syntax
expr
x
expr
expr)))))]
[else (same-k)])))))
(cond
[a (diff-k (cdr a))]
[(pair? expr)
(loop (car expr)
(lambda ()
(loop (cdr expr) same-k
(lambda (y) (diff-k (cons (car expr) y)))))
(lambda (x)
(loop (cdr expr)
(lambda () (diff-k (cons x (cdr expr))))
(lambda (y) (diff-k (cons x y))))))]
[(vector? expr)
(loop (vector->list expr) same-k
(lambda (x) (diff-k (list->vector x))))]
[(box? expr)
(loop (unbox expr) same-k (lambda (x) (diff-k (box x))))]
[(syntax? expr)
(if (identifier? expr)
(same-k)
(loop (syntax-e expr) same-k
(lambda (x) (diff-k (datum->syntax expr x expr expr)))))]
[else (same-k)]))))
(define (append-rebuild expr end)
(cond

23
collects/lang/htdp-langs.rkt
View File

@ -1076,7 +1076,7 @@
(define test-coverage-enabled (make-parameter #t))
(define current-test-coverage-info (make-thread-cell #f))
(define (initialize-test-coverage-point key expr)
(define (initialize-test-coverage-point expr)
(unless (thread-cell-ref current-test-coverage-info)
(let ([ht (make-hasheq)])
(thread-cell-set! current-test-coverage-info ht)
@ -1144,16 +1144,19 @@
(send rep set-test-coverage-info ht on-sd off-sd #f)))))))))
(let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht
(hash-set! ht key (mcons #f expr)))))
(hash-set! ht expr #;(box #f) (mcons #f #f)))))
(define (test-covered key)
(let* ([ht (thread-cell-ref current-test-coverage-info)]
[v (and ht (hash-ref ht key #f))])
(with-syntax ([v v])
#'(set-mcar! v #t))
#;
(and v
(λ () (set-mcar! v #t)))))
(define (test-covered expr)
(let* ([ht (or (thread-cell-ref current-test-coverage-info)
(error 'htdp-langs
"internal-error: no test-coverage table"))]
[v (hash-ref ht expr
(lambda ()
(error 'htdp-langs
"internal-error: expression not found: ~.s"
expr)))])
#; (lambda () (set-box! v #t))
(with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))
(define-values/invoke-unit et:stacktrace@
(import et:stacktrace-imports^) (export (prefix et: et:stacktrace^)))

16
collects/racket/match/compiler.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require (for-template scheme/base "runtime.rkt" scheme/stxparam)
(require (for-template scheme/base "runtime.rkt" scheme/stxparam racket/unsafe/ops)
syntax/boundmap
syntax/stx
"patterns.rkt"
@ -60,12 +60,13 @@
#`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))
(cond
[(eq? 'box k)
(compile-con-pat (list #'unbox) #'box? (compose list Box-p))]
(compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))]
[(eq? 'pair k)
(compile-con-pat (list #'car #'cdr) #'pair?
(compile-con-pat (list #'unsafe-car #'unsafe-cdr) #'pair?
(lambda (p) (list (Pair-a p) (Pair-d p))))]
[(eq? 'mpair k)
(compile-con-pat (list #'mcar #'mcdr) #'mpair?
; XXX These should be unsafe-mcar* when mpairs have chaperones
(compile-con-pat (list #'unsafe-mcar #'unsafe-mcdr) #'mpair?
(lambda (p) (list (MPair-a p) (MPair-d p))))]
[(eq? 'string k) (constant-pat #'string?)]
[(eq? 'number k) (constant-pat #'number?)]
@ -104,10 +105,10 @@
esc)]
[(n ...) ns])
#`[(#,arity)
(let ([tmps (vector-ref #,x n)] ...)
(let ([tmps (unsafe-vector*-ref #,x n)] ...)
body)]))))])])
#`[(vector? #,x)
(case (vector-length #,x)
(case (unsafe-vector*-length #,x)
clauses ...
[else (#,esc)])])]
;; it's a structure
@ -115,6 +116,9 @@
;; all the rows are structures with the same predicate
(let* ([s (Row-first-pat (car rows))]
[accs (Struct-accessors s)]
[accs (if (Struct-complete? s)
(build-list (length accs) (λ (i) #`(λ (x) (unsafe-struct*-ref x #,i))))
accs)]
[pred (Struct-pred s)])
(compile-con-pat accs pred Struct-ps))]
[else (error 'match-compile "bad key: ~a" k)]))

70
collects/racket/match/parse-helper.rkt
View File

@ -85,43 +85,47 @@
(let ([super (list-ref (extract-struct-info (syntax-local-value
struct-name))
5)])
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(cond [(equal? super #t) (values #t '())] ;; no super type exists
[(equal? super #f) (values #f '())] ;; super type is unknown
[else
(let-values ([(complete? lineage) (get-lineage super)])
(values complete?
(cons super lineage)))])))
(unless pred
(raise-syntax-error 'match (format "structure ~a does not have an associated predicate"
(syntax->datum struct-name))
stx struct-name))
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
(get-lineage (cert struct-name))
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)]))))))
(let-values ([(complete? lineage) (get-lineage (cert struct-name))])
(let* (;; the accessors come in reverse order
[acc (reverse acc)]
;; remove the first element, if it's #f
[acc (cond [(null? acc) acc]
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct pred
(syntax-property
pred
'disappeared-use (list struct-name))
lineage complete?
acc
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)])))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer pat))))

3
collects/racket/match/patterns.rkt
View File

@ -55,9 +55,10 @@
;; pred is an identifier
;; super is an identifier, or #f
;; complete? is a boolean
;; accessors is a listof identifiers (NB in reverse order from the struct info)
;; ps is a listof patterns
(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
(define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent)
;; both fields are lists of pats
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)

125
collects/racket/private/sandbox-coverage.rkt
View File

@ -1,70 +1,73 @@
;; This file is is used in the context of sandboxed code, it uses the
;; stacktrace interface from errortrace to find uncovered expressions.
(module sandbox-coverage mzscheme
(require errortrace/stacktrace mzlib/unit mzlib/list)
#lang racket/base
(require errortrace/stacktrace racket/unit (for-template racket/base))
;; Test coverage run-time support
(define test-coverage-enabled (make-parameter #t))
(define test-coverage-info (make-hash-table))
(define (initialize-test-coverage-point key expr)
(hash-table-put! test-coverage-info key (mcons expr #f)))
(define (test-covered key)
(let ([mpair (hash-table-get test-coverage-info key)])
(λ () (set-mcdr! mpair #t))))
;; Test coverage run-time support
(define test-coverage-enabled (make-parameter #t))
(define test-coverage-info (make-hasheq))
(define (initialize-test-coverage-point expr)
(hash-set! test-coverage-info expr (mcons #f #f)))
(define (test-covered expr)
(let ([v (hash-ref test-coverage-info expr
(lambda ()
(error 'sandbox-coverage
"internal error: no info for ~.s" expr)))])
(and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))))
(define (get-uncovered-expressions)
(let* ([xs (hash-table-map test-coverage-info (lambda (k v)
(cons (mcar v) (mcdr v))))]
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
[xs (sort xs (lambda (x1 x2)
(let ([p1 (syntax-position (car x1))]
[p2 (syntax-position (car x2))])
(or (< p1 p2) ; earlier first
(and (= p1 p2)
(> (syntax-span (car x1)) ; wider first
(syntax-span (car x2))))))))]
[xs (reverse xs)])
(if (null? xs)
xs
(let loop ([xs (cdr xs)] [r (list (car xs))])
(if (null? xs)
(map car (filter (lambda (x) (not (cdr x))) r))
(loop (cdr xs)
(cond [(not (and (= (syntax-position (caar xs))
(syntax-position (caar r)))
(= (syntax-span (caar xs))
(syntax-span (caar r)))))
(cons (car xs) r)]
[(cdar r) r]
[else (cons (car xs) (cdr r))])))))))
(define (get-uncovered-expressions)
(let* ([xs (hash-map test-coverage-info
(lambda (k v) (cons k (mcar v))))]
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
[xs (sort xs (lambda (x1 x2)
(let ([p1 (syntax-position (car x1))]
[p2 (syntax-position (car x2))])
(or (< p1 p2) ; earlier first
(and (= p1 p2)
(> (syntax-span (car x1)) ; wider first
(syntax-span (car x2))))))))]
[xs (reverse xs)])
(if (null? xs)
xs
(let loop ([xs (cdr xs)] [r (list (car xs))])
(if (null? xs)
(map car (filter (lambda (x) (not (cdr x))) r))
(loop (cdr xs)
(cond [(not (and (= (syntax-position (caar xs))
(syntax-position (caar r)))
(= (syntax-span (caar xs))
(syntax-span (caar r)))))
(cons (car xs) r)]
[(cdar r) r]
[else (cons (car xs) (cdr r))])))))))
(provide get-uncovered-expressions)
(provide get-uncovered-expressions)
;; no profiling
(define profile-key #f)
(define profiling-enabled (lambda () #f))
(define initialize-profile-point void)
(define register-profile-start void)
(define register-profile-done void)
;; no marks
(define (with-mark mark expr) expr)
;; no profiling
(define profile-key #f)
(define profiling-enabled (lambda () #f))
(define initialize-profile-point void)
(define register-profile-start void)
(define register-profile-done void)
;; no marks
(define (with-mark mark expr) expr)
(define-values/invoke-unit/infer stacktrace@)
(define-values/invoke-unit/infer stacktrace@)
(define errortrace-compile-handler
(let ([orig (current-compile)]
[ns (current-namespace)])
(lambda (e immediate-eval?)
(orig (if (and (eq? ns (current-namespace))
(not (compiled-expression?
(if (syntax? e) (syntax-e e) e))))
(annotate-top
(expand-syntax (if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax-object #f e))))
(namespace-base-phase))
e)
immediate-eval?))))
(define errortrace-compile-handler
(let ([orig (current-compile)]
[ns (current-namespace)])
(lambda (e immediate-eval?)
(orig (if (and (eq? ns (current-namespace))
(not (compiled-expression?
(if (syntax? e) (syntax-e e) e))))
(annotate-top
(expand-syntax (if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax #f e))))
(namespace-base-phase))
e)
immediate-eval?))))
(current-compile errortrace-compile-handler))
(current-compile errortrace-compile-handler)

12
collects/tests/match/plt-match-tests.rkt
View File

@ -179,6 +179,18 @@
(else #f)))
(check-true (origin? (make-point 0 0)))
(check-false (origin? (make-point 1 1)))))
; This test ensures that the unsafe struct optimization is correct
(test-case "struct patterns (with opaque parent)"
(let ()
(define-struct opq (any))
(parameterize ([current-inspector (make-sibling-inspector)])
(define-struct point (x y) #:super struct:opq)
(define (origin? pt)
(match pt
((struct point (0 0)) #t)
(else #f)))
(check-true (origin? (make-point 'a 0 0)))
(check-false (origin? (make-point 'a 1 1))))))
))
(define nonlinear-tests

52
collects/web-server/scribblings/tutorial/continue.scrbl
View File

@ -62,9 +62,9 @@ By the end of this tutorial, we'll have a simple blogging application.
We start by considering our data definitions. We want to represent a
list of posts. Let's say that a post is:
@racketblock[(define-struct post (title body))]
@racketblock[(struct post (title body))]
@(defstruct post ([title string?] [body string?]))
@(defstruct* post ([title string?] [body string?]))
@bold{Exercise.} Make a few examples of posts.
@ -75,8 +75,8 @@ A blog, then, will be a list of posts:
As a very simple example of a blog:
@racketblock[
(define BLOG (list (make-post "First Post!"
"Hey, this is my first post!")))
(define BLOG (list (post "First Post!"
"Hey, this is my first post!")))
]
Now that we have a sample blog structure, let's get our web
@ -172,7 +172,7 @@ an @racket[html-response] representing that content.
As an example, we want:
@racketblock[
(render-post (make-post "First post!" "This is a first post."))
(render-post (post "First post!" "This is a first post."))
]
to produce:
@ -229,8 +229,8 @@ should produce:
While
@racketblock[
(render-posts (list (make-post "Post 1" "Body 1")
(make-post "Post 2" "Body 2")))
(render-posts (list (post "Post 1" "Body 1")
(post "Post 2" "Body 2")))
]
should produce:
@ -441,9 +441,9 @@ Earlier, we had said that a @racket[blog] was a list of @racket[post]s,
but because we want to allow the blog to be changed, let's revisit our
definition so that a blog is a mutable structure:
@racketblock[(define-struct blog (posts) #:mutable)]
@racketblock[(struct blog (posts) #:mutable)]
@defstruct[blog ([posts (listof post?)])]
@defstruct*[blog ([posts (listof post?)])]
Mutable structures provide functions to change the fields of a
structure; in this case, we now have a structure mutator called
@ -484,7 +484,7 @@ the same blog.
Next, let's extend the application so that each post can hold a list
of comments. We refine the data definition of a blog to be:
@defstruct[post ([title string?] [body string?] [comments (listof string?)]) #:mutable]
@defstruct*[post ([title string?] [body string?] [comments (listof string?)]) #:mutable]
@bold{Exercise.} Write the updated data structure definition for posts. Make
sure to make the structure mutable, since we intend to add comments to
@ -504,7 +504,7 @@ comments in an itemized list.
@bold{Exercise.} Because we've extended a post to include comments, other
post-manipulating parts of the application may need to be adjusted,
such as uses of @racket[make-post]. Identify and fix any other part of the
such as uses of @racket[post]. Identify and fix any other part of the
application that needs to accommodate the post's new structure.
@centerline{------------}
@ -736,8 +736,8 @@ between the model of our blog, and the web application that uses that
model. Let's isolate the model: it's all the stuff near the top:
@racketblock[
(define-struct blog (posts) #:mutable)
(define-struct post (title body comments) #:mutable)
(struct blog (posts) #:mutable)
(struct post (title body comments) #:mutable)
(define BLOG ...)
(define (blog-insert-post! ...) ...)
(define (post-insert-comment! ...) ...)
@ -794,7 +794,7 @@ started running---which is exactly what we want when restoring the blog data fro
Our blog structure definition now looks like:
@racketblock[
(define-struct blog (posts) #:mutable #:prefab)
(struct blog (posts) #:mutable #:prefab)
]
Now @racket[blog] structures can be read from the outside world with @racket[read] and written
@ -809,7 +809,7 @@ At this point, we @emph{can} read and write the blog to disk. Now let's actually
First, we'll make a place to record in the model where the blog lives on disk. So, we need to change
the blog structure again. Now it will be:
@defstruct[blog ([home string?] [posts (listof post?)]) #:mutable]
@defstruct*[blog ([home string?] [posts (listof post?)]) #:mutable]
@bold{Exercise.} Write the new structure definition for blogs.
@ -820,14 +820,14 @@ Then, we'll make a function that allows our application to initialize the blog:
@code:comment{Reads a blog from a path, if not present, returns default}
(define (initialize-blog! home)
(local [(define (log-missing-exn-handler exn)
(make-blog
(blog
(path->string home)
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
(define the-blog
(with-handlers ([exn? log-missing-exn-handler])
(with-input-from-file home read)))]
@ -983,7 +983,7 @@ By adding a new comments table, we are more in accord with the relational style.
A @racket[blog] structure will simply be a container for the database handle:
@defstruct[blog ([db sqlite:db?])]
@defstruct*[blog ([db sqlite:db?])]
@bold{Exercise.} Write the @racket[blog] structure definition. (It does not need to be mutable or serializable.)
@ -993,7 +993,7 @@ We can now write the code to initialize a @racket[blog] structure:
@code:comment{Sets up a blog database (if it doesn't exist)}
(define (initialize-blog! home)
(define db (sqlite:open home))
(define the-blog (make-blog db))
(define the-blog (blog db))
(with-handlers ([exn? void])
(sqlite:exec/ignore db
(string-append
@ -1056,7 +1056,7 @@ However, we cannot tell from this structure
what blog this posts belongs to, and therefore, what database; so, we could not extract the title or body values,
since we do not know what to query. Therefore, we should associate the blog with each post:
@defstruct[post ([blog blog?] [id integer?])]
@defstruct*[post ([blog blog?] [id integer?])]
@bold{Exercise.} Write the structure definition for posts.
@ -1067,7 +1067,7 @@ The only function that creates posts is @racket[blog-posts]:
@code:comment{Queries for the post ids}
(define (blog-posts a-blog)
(local [(define (row->post a-row)
(make-post
(post
a-blog
(vector-ref a-row 0)))
(define rows (sqlite:select

8
collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
View File

@ -3,17 +3,17 @@
;; A blog is a (make-blog db)
;; where db is an sqlite database handle
(define-struct blog (db))
(struct blog (db))
;; A post is a (make-post blog id)
;; where blog is a blog and id is an integer?
(define-struct post (blog id))
(struct post (blog id))
;; initialize-blog! : path? -> blog?
;; Sets up a blog database (if it doesn't exist)
(define (initialize-blog! home)
(define db (sqlite:open home))
(define the-blog (make-blog db))
(define the-blog (blog db))
(with-handlers ([exn? void])
(sqlite:exec/ignore db
(string-append
@ -35,7 +35,7 @@
;; Queries for the post ids
(define (blog-posts a-blog)
(local [(define (row->post a-row)
(make-post a-blog (string->number (vector-ref a-row 0))))
(post a-blog (string->number (vector-ref a-row 0))))
(define rows (sqlite:select
(blog-db a-blog)
"SELECT id FROM posts"))]

10
collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
View File

@ -2,20 +2,20 @@
;; A blog is a (listof post)
;; and a post is a (make-post title body)
(define-struct post (title body))
(struct post (title body))
;; BLOG: blog
;; The static blog.
(define BLOG
(list (make-post "First Post" "This is my first post")
(make-post "Second Post" "This is another post")))
(list (post "First Post" "This is my first post")
(post "Second Post" "This is another post")))
;; start: request -> html-response
;; Consumes a request, and produces a page that displays all of the
;; web content.
(define (start request)
(render-blog-page BLOG request))
;; render-blog-page: blog request -> html-response
;; Consumes a blog and a request, and produces an html-response page
;; of the content of the blog.
@ -23,7 +23,7 @@
`(html (head (title "My Blog"))
(body (h1 "My Blog")
,(render-posts a-blog))))
;; render-post: post -> html-response
;; Consumes a post, produces an html-response fragment of the post.
(define (render-post a-post)

14
collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
View File

@ -2,13 +2,13 @@
;; A blog is a (listof post)
;; and a post is a (make-post title body)
(define-struct post (title body))
(struct post (title body))
;; BLOG: blog
;; The static blog.
(define BLOG
(list (make-post "First Post" "This is my first post")
(make-post "Second Post" "This is another post")))
(list (post "First Post" "This is my first post")
(post "Second Post" "This is another post")))
;; start: request -> html-response
;; Consumes a request and produces a page that displays all of the
@ -21,7 +21,7 @@
[else
BLOG]))]
(render-blog-page a-blog request)))
;; can-parse-post?: bindings -> boolean
;; Produces true if bindings contains values for 'title and 'body.
@ -33,8 +33,8 @@
;; parse-post: bindings -> post
;; Consumes a bindings, and produces a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
;; render-blog-page: blog request -> html-response
;; Consumes a blog and a request, and produces an html-response page
@ -49,8 +49,6 @@
(input ((name "body")))
(input ((type "submit")))))))
;; render-post: post -> html-response
;; Consumes a post, produces an html-response fragment of the post.
(define (render-post a-post)

20
collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
View File

@ -2,25 +2,25 @@
;; A blog is a (listof post)
;; and a post is a (make-post title body)
(define-struct post (title body))
(struct post (title body))
;; BLOG: blog
;; The static blog.
(define BLOG
(list (make-post "First Post" "This is my first post")
(make-post "Second Post" "This is another post")))
(list (post "First Post" "This is my first post")
(post "Second Post" "This is another post")))
;; start: request -> html-response
;; Consumes a request and produces a page that displays all of the
;; web content.
(define (start request)
(render-blog-page BLOG request))
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
;; render-blog-page: blog request -> html-response
;; Consumes a blog and a request, and produces an html-response page
@ -33,16 +33,16 @@
,(render-posts a-blog)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(define (insert-post-handler request)
(render-blog-page
(cons (parse-post (request-bindings request))
a-blog)
request))]
(send/suspend/dispatch response-generator)))
;; render-post: post -> html-response

24
collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
View File

@ -2,25 +2,25 @@
;; A blog is a (make-blog posts)
;; where posts is a (listof post)
(define-struct blog (posts) #:mutable)
(struct blog (posts) #:mutable)
;; and post is a (make-post title body)
;; where title is a string, and body is a string
(define-struct post (title body))
(struct post (title body))
;; BLOG: blog
;; The initial BLOG.
(define BLOG
(make-blog
(list (make-post "First Post" "This is my first post")
(make-post "Second Post" "This is another post"))))
(blog
(list (post "First Post" "This is my first post")
(post "Second Post" "This is another post"))))
;; blog-insert-post!: blog post -> void
;; Consumes a blog and a post, adds the post at the top of the blog.
(define (blog-insert-post! a-blog a-post)
(set-blog-posts! a-blog
(cons a-post (blog-posts a-blog))))
;; start: request -> html-response
;; Consumes a request and produces a page that displays
;; all of the web content.
@ -30,8 +30,8 @@
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)))
;; render-blog-page: request -> html-response
;; Produces an html-response page of the content of the BLOG.
@ -43,15 +43,15 @@
,(render-posts)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(define (insert-post-handler request)
(blog-insert-post!
BLOG (parse-post (request-bindings request)))
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-post: post -> html-response

38
collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
View File

@ -2,23 +2,23 @@
;; A blog is a (make-blog posts)
;; where posts is a (listof post)
(define-struct blog (posts) #:mutable)
(struct blog (posts) #:mutable)
;; and post is a (make-post title body comments)
;; where title is a string, body is a string,
;; and comments is a (listof string)
(define-struct post (title body comments) #:mutable)
(struct post (title body comments) #:mutable)
;; BLOG: blog
;; The initial BLOG.
(define BLOG
(make-blog
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(blog
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
;; blog-insert-post!: blog post -> void
;; Consumes a blog and a post, adds the post at the top of the blog.
@ -52,22 +52,22 @@
,(render-posts make-url)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(define (insert-post-handler request)
(blog-insert-post!
BLOG (parse-post (request-bindings request)))
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-post-detail-page: post request -> html-response
@ -86,7 +86,7 @@
,(make-url insert-comment-handler)))
(input ((name "comment")))
(input ((type "submit")))))))
(define (parse-comment bindings)
(extract-binding/single 'comment bindings))
@ -94,8 +94,8 @@
(post-insert-comment!
a-post (parse-comment (request-bindings a-request)))
(render-post-detail-page a-post a-request))]
(send/suspend/dispatch response-generator)))

36
collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
View File

@ -2,23 +2,23 @@
;; A blog is a (make-blog posts)
;; where posts is a (listof post)
(define-struct blog (posts) #:mutable)
(struct blog (posts) #:mutable)
;; and post is a (make-post title body comments)
;; where title is a string, body is a string,
;; and comments is a (listof string)
(define-struct post (title body comments) #:mutable)
(struct post (title body comments) #:mutable)
;; BLOG: blog
;; The initial BLOG.
(define BLOG
(make-blog
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(blog
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
;; blog-insert-post!: blog post -> void
;; Consumes a blog and a post, adds the post at the top of the blog.
@ -52,22 +52,22 @@
,(render-posts make-url)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(define (insert-post-handler request)
(blog-insert-post!
BLOG (parse-post (request-bindings request)))
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-post-detail-page: post request -> html-response
@ -101,7 +101,7 @@
(define (back-handler request)
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-confirm-add-comment-page :
@ -130,7 +130,7 @@
(define (cancel-handler request)
(render-post-detail-page a-post request))]
(send/suspend/dispatch response-generator)))
;; render-post: post (handler -> string) -> html-response

38
collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
View File

@ -2,23 +2,23 @@
;; A blog is a (make-blog posts)
;; where posts is a (listof post)
(define-struct blog (posts) #:mutable)
(struct blog (posts) #:mutable)
;; and post is a (make-post title body comments)
;; where title is a string, body is a string,
;; and comments is a (listof string)
(define-struct post (title body comments) #:mutable)
(struct post (title body comments) #:mutable)
;; BLOG: blog
;; The initial BLOG.
(define BLOG
(make-blog
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(blog
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
;; blog-insert-post!: blog post -> void
;; Consumes a blog and a post, adds the post at the top of the blog.
@ -52,22 +52,22 @@
,(render-posts make-url)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(define (insert-post-handler request)
(blog-insert-post!
BLOG (parse-post (request-bindings request)))
(render-blog-page (redirect/get)))]
(send/suspend/dispatch response-generator)))
;; render-post-detail-page: post request -> html-response
@ -98,10 +98,10 @@
(parse-comment (request-bindings request))
a-post
request))
(define (back-handler request)
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-confirm-add-comment-page :
@ -130,7 +130,7 @@
(define (cancel-handler request)
(render-post-detail-page a-post request))]
(send/suspend/dispatch response-generator)))
;; render-post: post (handler -> string) -> html-response

20
collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
View File

@ -19,22 +19,22 @@
,(render-posts make-url)
(form ((action
,(make-url insert-post-handler)))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
(input ((name "title")))
(input ((name "body")))
(input ((type "submit")))))))
;; parse-post: bindings -> post
;; Extracts a post out of the bindings.
(define (parse-post bindings)
(make-post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(post (extract-binding/single 'title bindings)
(extract-binding/single 'body bindings)
(list)))
(define (insert-post-handler request)
(blog-insert-post!
BLOG (parse-post (request-bindings request)))
(render-blog-page (redirect/get)))]
(send/suspend/dispatch response-generator)))
;; render-post-detail-page: post request -> html-response
@ -65,10 +65,10 @@
(parse-comment (request-bindings request))
a-post
request))
(define (back-handler request)
(render-blog-page request))]
(send/suspend/dispatch response-generator)))
;; render-confirm-add-comment-page :
@ -97,7 +97,7 @@
(define (cancel-handler request)
(render-post-detail-page a-post request))]
(send/suspend/dispatch response-generator)))
;; render-post: post (handler -> string) -> html-response

20
collects/web-server/scribblings/tutorial/examples/model-2.rkt
View File

@ -2,25 +2,25 @@
;; A blog is a (make-blog home posts)
;; where home is a string, posts is a (listof post)
(define-struct blog (home posts) #:mutable #:prefab)
(struct blog (home posts) #:mutable #:prefab)
;; and post is a (make-post blog title body comments)
;; where title is a string, body is a string,
;; and comments is a (listof string)
(define-struct post (title body comments) #:mutable #:prefab)
(struct post (title body comments) #:mutable #:prefab)
;; initialize-blog! : path? -> blog
;; Reads a blog from a path, if not present, returns default
(define (initialize-blog! home)
(local [(define (log-missing-exn-handler exn)
(make-blog
(blog
(path->string home)
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
(define the-blog
(with-handlers ([exn? log-missing-exn-handler])
(with-input-from-file home read)))]
@ -41,7 +41,7 @@
(define (blog-insert-post! a-blog title body)
(set-blog-posts!
a-blog
(cons (make-post title body empty) (blog-posts a-blog)))
(cons (post title body empty) (blog-posts a-blog)))
(save-blog! a-blog))
;; post-insert-comment!: blog post string -> void

8
collects/web-server/scribblings/tutorial/examples/model-3.rkt
View File

@ -3,17 +3,17 @@
;; A blog is a (make-blog db)
;; where db is an sqlite database handle
(define-struct blog (db))
(struct blog (db))
;; A post is a (make-post blog id)
;; where blog is a blog and id is an integer?
(define-struct post (blog id))
(struct post (blog id))
;; initialize-blog! : path? -> blog?
;; Sets up a blog database (if it doesn't exist)
(define (initialize-blog! home)
(define db (sqlite:open home))
(define the-blog (make-blog db))
(define the-blog (blog db))
(with-handlers ([exn? void])
(sqlite:exec/ignore db
(string-append
@ -35,7 +35,7 @@
;; Queries for the post ids
(define (blog-posts a-blog)
(local [(define (row->post a-row)
(make-post
(post
a-blog
(vector-ref a-row 0)))
(define rows (sqlite:select

18
collects/web-server/scribblings/tutorial/examples/model.rkt
View File

@ -2,23 +2,23 @@
;; A blog is a (make-blog posts)
;; where posts is a (listof post)
(define-struct blog (posts) #:mutable)
(struct blog (posts) #:mutable)
;; and post is a (make-post title body comments)
;; where title is a string, body is a string,
;; and comments is a (listof string)
(define-struct post (title body comments) #:mutable)
(struct post (title body comments) #:mutable)
;; BLOG: blog
;; The initial BLOG.
(define BLOG
(make-blog
(list (make-post "First Post"
"This is my first post"
(list "First comment!"))
(make-post "Second Post"
"This is another post"
(list)))))
(blog
(list (post "First Post"
"This is my first post"
(list "First comment!"))
(post "Second Post"
"This is another post"
(list)))))
;; blog-insert-post!: blog post -> void
;; Consumes a blog and a post, adds the post at the top of the blog.

4
collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
View File

@ -2,7 +2,7 @@
;; A roster is a (make-roster names)
;; where names is a list of string.
(define-struct roster (names) #:mutable)
(struct roster (names) #:mutable)
;; roster-add-name!: roster string -> void
;; Given a roster and a name, adds the name
@ -12,7 +12,7 @@
(append (roster-names a-roster)
(list a-name))))
(define ROSTER (make-roster '("kathi" "shriram" "dan")))
(define ROSTER (roster '("kathi" "shriram" "dan")))
;; start: request -> html-response
(define (start request)

4
collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
View File

@ -2,7 +2,7 @@
;; A roster is a (make-roster names)
;; where names is a list of string.
(define-struct roster (names) #:mutable)
(struct roster (names) #:mutable)
;; roster-add-name!: roster string -> void
;; Given a roster and a name, adds the name
@ -12,7 +12,7 @@
(append (roster-names a-roster)
(list a-name))))
(define ROSTER (make-roster '("kathi" "shriram" "dan")))
(define ROSTER (roster '("kathi" "shriram" "dan")))
;; start: request -> html-response
(define (start request)

2
collects/web-server/servlet-dispatch.rkt
View File

@ -135,7 +135,7 @@
(if launch-path
(string-append server-url launch-path)
server-url))
(printf "Click 'Stop' at any time to terminate the Web Server.\n"))
(printf "Stop this program at any time to terminate the Web Server.\n"))
(let ([bye (lambda ()
(when banner? (printf "\nWeb Server stopped.\n"))
(shutdown-server))])