140 lines
5.1 KiB
Racket
140 lines
5.1 KiB
Racket
#lang s-exp "../lang/base.rkt"
|
|
|
|
(require "impl.rkt"
|
|
"helpers.rkt"
|
|
"event.rkt"
|
|
(for-syntax racket/base))
|
|
|
|
(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"))
|
|
|
|
(provide view-bind-many
|
|
view-bind-many*
|
|
view-prepend-child)
|
|
|
|
|
|
(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))
|
|
|
|
|
|
|
|
;; A syntactic form to make it more convenient to focus and bind multiple things
|
|
;; (view-bind-many a-view
|
|
;; [id type function]
|
|
;; [id type function] ...)
|
|
(define-syntax (view-bind-many stx)
|
|
(syntax-case stx ()
|
|
[(_ a-view [a-selector a-type a-function] ...)
|
|
(foldl (lambda (a-selector a-type a-function a-view-stx)
|
|
#`(view-bind (view-focus #,a-view-stx #,a-selector)
|
|
#,a-type
|
|
#,a-function))
|
|
#'(->view a-view)
|
|
(syntax->list #'(a-selector ...))
|
|
(syntax->list #'(a-type ...))
|
|
(syntax->list #'(a-function ...)))]))
|
|
|
|
|
|
;; We also provide a function to do the same thing, just in case.
|
|
(define (view-bind-many* a-view listof-id+type+function)
|
|
|
|
(define (string-or-symbol? x)
|
|
(or (string? x)
|
|
(symbol? x)))
|
|
|
|
(unless (list? listof-id+type+function)
|
|
(raise-type-error 'view-bind-many*
|
|
"(listof (list id-string event-type-string world-updater))"
|
|
listof-id+type+function))
|
|
(foldl (lambda (id+type+function a-view)
|
|
(unless (and (list? id+type+function)
|
|
(string-or-symbol? (first id+type+function))
|
|
(string-or-symbol? (second id+type+function))
|
|
(procedure? (third id+type+function)))
|
|
(raise-type-error 'view-bind-many*
|
|
"(list id-string event-type-string world-updater)"
|
|
id+type+function))
|
|
(view-bind (view-focus a-view (first id+type+function))
|
|
(second id+type+function)
|
|
(third id+type+function)))
|
|
(->view a-view)
|
|
listof-id+type+function))
|
|
|
|
|
|
|
|
(define (view-prepend-child a-view c)
|
|
(unless (view? a-view)
|
|
(raise-type-error 'view-prepend-child
|
|
"view"
|
|
a-view))
|
|
(cond
|
|
[(view-down? a-view)
|
|
(view-insert-left (view-down a-view) c)]
|
|
[else
|
|
(view-append-child a-view c)])) |