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

wrapped all the web-world handlers with syntaxes that check that they're being used in a big-bang lexical context

Browse Source
This commit is contained in:
Danny Yoo 2011-12-08 18:09:08 -05:00
parent 3905f31cc7
commit 2d10681a26
2 changed files with 73 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
version.rkt
View File

@ -7,4 +7,4 @@
(provide version)
(: version String)
(define version "1.98")
(define version "1.99")

74
web-world/main.rkt
View File

@ -4,6 +4,76 @@
"helpers.rkt"
"event.rkt")
(provide (all-from-out "impl.rkt")
(require (for-syntax racket/base racket/stxparam-exptime)
(only-in "../lang/kernel.rkt" define-syntax-parameter syntax-parameterize))
(provide (except-out (all-from-out "impl.rkt")
big-bang
initial-view
stop-when
on-tick
on-mock-location-change
on-location-change
to-draw)
(all-from-out "helpers.rkt")
(all-from-out "event.rkt"))
(all-from-out "event.rkt"))
(provide (rename-out [internal-big-bang big-bang]
[big-bang big-bang/f]
[initial-view initial-view/f]
[stop-when stop-when/f]
[on-tick on-tick/f]
[on-mock-location-change on-mock-location-change/f]
[on-location-change on-location-change/f]
[to-draw to-draw/f]))
(define-syntax-parameter in-big-bang? #f)
(define-syntax (internal-big-bang stx)
(syntax-case stx ()
[(_ body ...)
(syntax/loc stx (big-bang (syntax-parameterize ([in-big-bang? #t])
body)
...))]
[else
(raise-syntax-error #f "big-bang should be applied")]))
(define-syntax (define/provide-protected stx)
(syntax-case stx ()
[(_ (real-function ...))
(with-syntax ([(internal-name ...)
(generate-temporaries (syntax->list #'(real-function ...)))])
(syntax/loc stx
(begin (begin (define-syntax (internal-name stx2)
(syntax-case stx2 ()
[(_ args (... ...))
(cond
[(syntax-parameter-value #'in-big-bang?)
(syntax/loc stx2
(real-function args (... ...)))]
[else
(raise-syntax-error #f (format "~a should be applied in the context of a big-bang"
'real-function)
stx2)])]
[else
(raise-syntax-error #f
(format "~a should be applied in the context of a big-bang"
'real-function)
stx2)]))
(provide (rename-out (internal-name real-function)))) ...)))]))
(define/provide-protected (initial-view
stop-when
on-tick
on-mock-location-change
on-location-change
to-draw))