[racket-dev] [plt] Push #21179: master branch updated
By the way, on a match intensive work-load, this improved performance by 2x.
Jay
On Mon, Oct 4, 2010 at 3:55 PM, Jay McCarthy <jay.mccarthy at gmail.com> wrote:
> One of the results of adding unsafe optimizations to match was that
> Sam and I noticed there were no unsafe-mcar* (like unsafe-unbox*) that
> shows there are no chaperones on mutable pairs.
>
> Jay
>
> On Mon, Oct 4, 2010 at 3:55 PM, <jay at racket-lang.org> wrote:
>> jay has updated `master' from 2f56b23b21 to 0c47e572c0.
>> http://git.racket-lang.org/plt/2f56b23b21..0c47e572c0
>>
>> =====[ 4 Commits ]======================================================
>>
>> Directory summary:
>> 27.1% collects/racket/match/
>> 3.5% collects/tests/match/
>> 53.9% collects/web-server/scribblings/tutorial/examples/
>> 14.5% collects/web-server/scribblings/tutorial/
>>
>> ~~~~~~~~~~
>>
>> 09fbfcf Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:38
>> :
>> | Fixing pr11280
>> :
>> M collects/web-server/scribblings/tutorial/continue.scrbl | 52 +++---
>> M collects/web-server/scribblings/tutorial/examples/model.rkt | 18 +-
>> M .../scribblings/tutorial/examples/no-use-redirect.rkt | 4 +-
>> M .../scribblings/tutorial/examples/use-redirect.rkt | 4 +-
>> M .../web-server/scribblings/tutorial/examples/dummy-3.rkt | 8 +-
>> M .../web-server/scribblings/tutorial/examples/iteration-1.rkt | 10 +-
>> M .../web-server/scribblings/tutorial/examples/iteration-2.rkt | 14 +-
>> M .../web-server/scribblings/tutorial/examples/iteration-3.rkt | 20 ++--
>> M .../web-server/scribblings/tutorial/examples/iteration-4.rkt | 24 ++--
>> M .../web-server/scribblings/tutorial/examples/iteration-5.rkt | 38 +++---
>> M .../web-server/scribblings/tutorial/examples/iteration-6.rkt | 36 +++---
>> M .../web-server/scribblings/tutorial/examples/iteration-7.rkt | 38 +++---
>> M .../web-server/scribblings/tutorial/examples/iteration-8.rkt | 20 ++--
>> M .../web-server/scribblings/tutorial/examples/model-2.rkt | 20 ++--
>> M .../web-server/scribblings/tutorial/examples/model-3.rkt | 8 +-
>>
>> ~~~~~~~~~~
>>
>> 61441bb Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:40
>> :
>> | Fixing pr11284
>> :
>> M collects/web-server/servlet-dispatch.rkt | 2 +-
>>
>> ~~~~~~~~~~
>>
>> 0965af6 Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:43
>> :
>> | Adding some unsafe ops to the match compiler
>> :
>> M collects/racket/match/compiler.rkt | 13 +++++++------
>>
>> ~~~~~~~~~~
>>
>> 0c47e57 Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:54
>> :
>> | Using unsafe operations in racket/match
>> :
>> M collects/racket/match/compiler.rkt | 3 +
>> M collects/racket/match/parse-helper.rkt | 70 ++++++++++++++-------------
>> M collects/racket/match/patterns.rkt | 3 +-
>> M collects/tests/match/plt-match-tests.rkt | 12 +++++
>>
>> =====[ Overall Diff ]===================================================
>>
>> collects/racket/match/compiler.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/racket/match/compiler.rkt
>> +++ NEW/collects/racket/match/compiler.rkt
>> @@ -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)]))
>>
>> collects/racket/match/parse-helper.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/racket/match/parse-helper.rkt
>> +++ NEW/collects/racket/match/parse-helper.rkt
>> @@ -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))))
>>
>> collects/racket/match/patterns.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/racket/match/patterns.rkt
>> +++ NEW/collects/racket/match/patterns.rkt
>> @@ -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)
>>
>> collects/tests/match/plt-match-tests.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/tests/match/plt-match-tests.rkt
>> +++ NEW/collects/tests/match/plt-match-tests.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/continue.scrbl
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/continue.scrbl
>> +++ NEW/collects/web-server/scribblings/tutorial/continue.scrbl
>> @@ -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:
>>
>> - at racketblock[(define-struct post (title body))]
>> + at 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:
>>
>> - at racketblock[(define-struct blog (posts) #:mutable)]
>> + at racketblock[(struct blog (posts) #:mutable)]
>>
>> - at defstruct[blog ([posts (listof post?)])]
>> + at 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:
>>
>> - at defstruct[post ([title string?] [body string?] [comments (listof string?)]) #:mutable]
>> + at 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:
>>
>> - at defstruct[blog ([home string?] [posts (listof post?)]) #:mutable]
>> + at 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:
>>
>> - at defstruct[blog ([db sqlite:db?])]
>> + at 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:
>>
>> - at defstruct[post ([blog blog?] [id integer?])]
>> + at 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
>>
>> collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
>> @@ -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"))]
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
>> @@ -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)
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
>> @@ -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)
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
>> @@ -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)))
>>
>>
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/model-2.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/model-2.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/model-2.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/model-3.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/model-3.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/model-3.rkt
>> @@ -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
>>
>> collects/web-server/scribblings/tutorial/examples/model.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/model.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/model.rkt
>> @@ -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.
>>
>> collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
>> @@ -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)
>>
>> collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
>> +++ NEW/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
>> @@ -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)
>>
>> collects/web-server/servlet-dispatch.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/collects/web-server/servlet-dispatch.rkt
>> +++ NEW/collects/web-server/servlet-dispatch.rkt
>> @@ -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))])
>>
>
>
>
> --
> Jay McCarthy <jay at cs.byu.edu>
> Assistant Professor / Brigham Young University
> http://teammccarthy.org/jay
>
> "The glory of God is Intelligence" - D&C 93
>
--
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay
"The glory of God is Intelligence" - D&C 93
![[logo]](/logo.png){kind=logo}