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

Reverting unfinished code

Browse Source 
svn: r11282
This commit is contained in:
Jay McCarthy 2008-08-15 19:44:37 +00:00
parent d4b04e3499
commit d101ba38fe
1 changed files with 11 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
collects/web-server/insta/insta.ss
View File

@ -1,7 +1,6 @@
#lang scheme #lang scheme
(require web-server/servlet (require web-server/servlet
web-server/servlet-env web-server/servlet-env)
(for-syntax syntax/kerncase))
(provide (provide
(all-from-out web-server/servlet) (all-from-out web-server/servlet)
@ -23,68 +22,15 @@
(define (no-web-browser) (define (no-web-browser)
(set! launch-browser? false)) (set! launch-browser? false))
(define-syntax (web-module-begin stx)
(define-syntax (web-module-begin stx)
;; check-for-start: syntax (listof syntax) -> (listof syntax)
;; Checks to see that the user has defined a request handler named "start".
;; Returns a list of the expanded syntax.
(define (check-for-start start-stx body-stxs)
(define (id-for-start? ids)
(ormap (lambda (id)
(and (identifier? id)
(free-identifier=? id start-stx)))
ids))
;; FIXME: this is not quite ready for prime time yet.
(let ([expanded-bodies
(let loop ([defns body-stxs])
(apply append
(map (lambda (defn)
(let ([d (local-expand
defn
'module
(kernel-form-identifier-list))])
(syntax-case d (define-values define-syntaxes begin)
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(define-values (id ...) body)
(list d)]
[(define-values . rest)
(list d)]
[(define-syntaxes (id ...) body)
(list d)]
[(define-syntaxes . rest)
(list d)]
[_else
(list d)])))
defns)))])
(let ([ids (apply append (map (lambda (b)
(let ([result
(syntax-case b ()
[(define-values (id ...) . __)
(syntax->list #'(id ...))]
[_ '()])])
result))
expanded-bodies))])
(unless (id-for-start? ids)
(raise-syntax-error #f "required \"start\" request handler needs to be defined" stx))
(values expanded-bodies))))
(syntax-case stx () (syntax-case stx ()
[(_ body ...) [(_ body ...)
(let ([start-stx (datum->syntax stx 'start)]) #'(#%module-begin
(with-syntax ([start start-stx] body ...
#;[(expanded-body ...) (provide/contract (start (request? . -> . response?)))
(check-for-start start-stx (syntax->list #'(body ...)))]) (if extra-files-path
#`(#%module-begin (serve/servlet start
body ... #:extra-files-path extra-files-path
(provide/contract (start (request? . -> . response?))) #:launch-browser? launch-browser?)
(if extra-files-path (serve/servlet start
(serve/servlet start #:launch-browser? launch-browser?)))]))
#:extra-files-path extra-files-path
#:launch-browser? launch-browser?)
(serve/servlet start
#:launch-browser? launch-browser?)))))]))