diff --git a/collects/frtime/demos/analog-clock.ss b/collects/frtime/demos/analog-clock.ss index 5dfd4cede7..61746ac5eb 100644 --- a/collects/frtime/demos/analog-clock.ss +++ b/collects/frtime/demos/analog-clock.ss @@ -31,7 +31,8 @@ (clicks-in-clock . -=> . (snapshot (mouse-pos clock-center) - (posn- mouse-pos clock-center))))) + (posn- mouse-pos clock-center))) + #;(make-posn 0 0))) ;; Define follow-mouse which is true when the center of the clock ;; should be at the mouse cursor; false when it is at the last @@ -47,9 +48,9 @@ (rec p (inf-delay (until (make-posn 200 200) - (let ([p1 (posn- mouse-pos offset)]) + (let ([p1 0]) (if follow-mouse? - p1 + (posn- mouse-pos offset) p)))))) ;; Define the length of the hands in terms of the radius of the clock. diff --git a/collects/frtime/demos/spreadsheet/spread.ss b/collects/frtime/demos/spreadsheet/spread.ss index 182b260903..e36a24ce0e 100644 --- a/collects/frtime/demos/spreadsheet/spread.ss +++ b/collects/frtime/demos/spreadsheet/spread.ss @@ -12,7 +12,7 @@ (lib "framework.ss" "framework") (as-is:unchecked (lib "string.ss") expr->string) (as-is:unchecked (lib "etc.ss") build-vector) - (lifted mzscheme regexp-match) + ;(lifted mzscheme regexp-match) (as-is:unchecked mzscheme make-hash-table hash-table-put! hash-table-get hash-table-remove! let*-values vector-set! make-string exn? @@ -346,10 +346,10 @@ [scrollbar-updater (list - (lift #t (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~) - (lift #t (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~) - (lift #t (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~) - (lift #t (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))] + (lift-strict (lambda (pg) (set-scroll-page 'horizontal (clip 1 (- pg chars-per-cell -1) 10000))) h-chars-per-page~) + (lift-strict (lambda (pg) (set-scroll-page 'vertical (clip 1 (sub1 pg) 10000))) v-cells-per-page~) + (lift-strict (lambda (rng) (set-scroll-range 'horizontal (clip 1 rng 10000))) h-scroll-range~) + (lift-strict (lambda (rng) (set-scroll-range 'vertical (clip 1 rng 10000))) v-scroll-range~))] [scroller ((merge-e (changes h-scroll-pos~) (changes v-scroll-pos~)) . -=> . (refresh))] @@ -409,7 +409,7 @@ [focuser ((key-events . =#> . (lambda (ev) (eq? #\return (send ev get-key-code)))) . -=> . (send text-field focus))] - [text-field-switcher (lift #t (lambda (row col) + [text-field-switcher (lift-strict (lambda (row col) (unless (or (negative? row) (negative? col)) (send text-field set-value (ss-get-cell-text row col)))) diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index f4b6500376..8c7741f73b 100644 --- a/collects/frtime/frp-core.ss +++ b/collects/frtime/frp-core.ss @@ -142,6 +142,17 @@ ; update the given signal at the given time (define-struct alarm (time signal)) + (define extra-cont-marks (make-parameter #f)) + + (define (effective-continuation-marks) + (if (extra-cont-marks) + (begin + #;(thread (lambda () (raise (make-exn:fail + "extra marks present!" (extra-cont-marks))))) + (compose-continuation-mark-sets + (extra-cont-marks) + (current-continuation-marks))) + (current-continuation-marks))) ;; Simple Structure Combinators @@ -162,7 +173,7 @@ (apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps))) (define (build-signal ctor thunk producers) - (let ([ccm (current-continuation-marks)]) + (let ([ccm (effective-continuation-marks)]) (do-in-manager (let* ([custs (current-custs)] [cust-sigs (map ft-cust-signal custs)] @@ -172,7 +183,8 @@ (map safe-signal-depth cust-sigs)))) ccm (parameterize ([current-exception-handler - (lambda (exn) (exn-handler exn))]) + (lambda (exn) (exn-handler exn))] + [extra-cont-marks ccm]) (current-parameterization)) (append cust-sigs producers))]) ;(printf "~a custodians~n" (length custs)) @@ -187,7 +199,7 @@ sig)))) (define (proc->signal:switching thunk current-box trigger . producers) - (let ([ccm (current-continuation-marks)]) + (let ([ccm (effective-continuation-marks)]) (do-in-manager (let* ([custs (current-custs)] [cust-sigs (map ft-cust-signal custs)] @@ -197,7 +209,8 @@ (map safe-signal-depth cust-sigs)))) ccm (parameterize ([current-exception-handler - (lambda (exn) (exn-handler exn))]) + (lambda (exn) (exn-handler exn))] + [extra-cont-marks ccm]) (current-parameterization)) (append cust-sigs producers) current-box @@ -221,57 +234,59 @@ ;; mutate! : compound num -> (any -> ()) (define (procs->signal:compound ctor mutate! . args) - (do-in-manager - (let* ([custs (current-custs)] - [cust-sigs (map ft-cust-signal custs)] - [value (apply ctor (map value-now/no-copy args))] - #;[mutators - (foldl - (lambda (arg idx acc) - (if (signal? arg) ; behavior? - (cons (proc->signal - (let ([m (mutate! value idx)]) - (lambda () - (let ([v (value-now/no-copy arg)]) - (m v) - 'struct-mutator))) - arg) acc) - acc)) - empty args (build-list (length args) identity))] - [sig (make-signal:compound - undefined - empty - #f - (lambda () ;mutators - (let loop ([i 0] [args args] [val value]) - (if (cons? args) - (let ([fd (value-now/no-copy (car args))]) - ((mutate! value i) fd) - (loop (add1 i) (cdr args) - (if (undefined? fd) - undefined - val))) - val))) - (add1 (apply max 0 (append (map safe-signal-depth args) - (map safe-signal-depth cust-sigs)))) - (current-continuation-marks) - (parameterize ([current-exception-handler - (lambda (exn) (exn-handler exn))]) - (current-parameterization)) - (append cust-sigs args) - (apply ctor args) - (lambda () (apply ctor (map value-now args))))]) - ;(printf "mutators = ~a~n" mutators) - (when (cons? args) - (register sig args)) - (when (cons? cust-sigs) - (register (make-non-scheduled sig) cust-sigs)) - (for-each (lambda (g) (set-ft-cust-constructed-sigs! - g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) - custs) - (iq-enqueue sig) - ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig)) - sig))) + (let ([ccm (effective-continuation-marks)]) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [value (apply ctor (map value-now/no-copy args))] + #;[mutators + (foldl + (lambda (arg idx acc) + (if (signal? arg) ; behavior? + (cons (proc->signal + (let ([m (mutate! value idx)]) + (lambda () + (let ([v (value-now/no-copy arg)]) + (m v) + 'struct-mutator))) + arg) acc) + acc)) + empty args (build-list (length args) identity))] + [sig (make-signal:compound + undefined + empty + #f + (lambda () ;mutators + (let loop ([i 0] [args args] [val value]) + (if (cons? args) + (let ([fd (value-now/no-copy (car args))]) + ((mutate! value i) fd) + (loop (add1 i) (cdr args) + (if (undefined? fd) + undefined + val))) + val))) + (add1 (apply max 0 (append (map safe-signal-depth args) + (map safe-signal-depth cust-sigs)))) + ccm + (parameterize ([current-exception-handler + (lambda (exn) (exn-handler exn))] + [extra-cont-marks ccm]) + (current-parameterization)) + (append cust-sigs args) + (apply ctor args) + (lambda () (apply ctor (map value-now args))))]) + ;(printf "mutators = ~a~n" mutators) + (when (cons? args) + (register sig args)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) + custs) + (iq-enqueue sig) + ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig)) + sig)))) @@ -597,32 +612,34 @@ (define (super-lift fun bhvr) (if (behavior? bhvr) - (do-in-manager - (let* ([cust (make-ft-cust (void) empty)] - [custs (cons cust (current-custs))] - [pfun (lambda (b) - (parameterize ([current-custs custs]) - (fun b)))] - [current (box undefined)]) - (letrec ([custodian-signal - (proc->signal:unchanged - (lambda () - (for-each kill-signal - (filter identity - (map weak-box-value (ft-cust-constructed-sigs cust)))) - (unregister rtn (unbox current)) - (set-box! current (pfun (value-now/no-copy bhvr))) - (register rtn (unbox current)) - ;; keep rtn's producers up-to-date - (set-car! (signal-producers rtn) (unbox current)) - (iq-resort) - 'custodian) - bhvr)] - [rtn (proc->signal:switching - (lambda () custodian-signal (value-now/no-copy (unbox current))) - current custodian-signal undefined bhvr custodian-signal)]) - (set-ft-cust-signal! cust custodian-signal) - rtn))) + (parameterize ([extra-cont-marks + (effective-continuation-marks)]) + (do-in-manager + (let* ([cust (make-ft-cust (void) empty)] + [custs (cons cust (current-custs))] + [pfun (lambda (b) + (parameterize ([current-custs custs]) + (fun b)))] + [current (box undefined)]) + (letrec ([custodian-signal + (proc->signal:unchanged + (lambda () + (for-each kill-signal + (filter identity + (map weak-box-value (ft-cust-constructed-sigs cust)))) + (unregister rtn (unbox current)) + (set-box! current (pfun (value-now/no-copy bhvr))) + (register rtn (unbox current)) + ;; keep rtn's producers up-to-date + (set-car! (signal-producers rtn) (unbox current)) + (iq-resort) + 'custodian) + bhvr)] + [rtn (proc->signal:switching + (lambda () custodian-signal (value-now/no-copy (unbox current))) + current custodian-signal undefined bhvr custodian-signal)]) + (set-ft-cust-signal! cust custodian-signal) + rtn)))) (fun bhvr))) @@ -725,11 +742,14 @@ (lambda (exn) (when (and cur-beh #;(not (undefined? (signal-value cur-beh)))) - #;(when (empty? (continuation-mark-set->list - (exn-continuation-marks exn) 'frtime)) - (set! exn (make-exn:fail (exn-message exn) - (signal-continuation-marks - cur-beh)))) + ;(when (empty? (continuation-mark-set->list + ; (exn-continuation-marks exn) 'frtime)) + (set! exn (make-exn:fail + (exn-message exn) + (compose-continuation-mark-sets + (signal-continuation-marks + cur-beh) + (exn-continuation-marks exn))));) ;(raise exn) (iq-enqueue (list exceptions (list exn cur-beh))) (when (behavior? cur-beh) diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss index d22816bf69..17abf62c67 100644 --- a/collects/frtime/lang-ext.ss +++ b/collects/frtime/lang-ext.ss @@ -526,6 +526,92 @@ out)]) (apply proc->signal thunk args))))) + (define current-emit (make-parameter #f)) + (define current-select (make-parameter #f)) + (define (emit ev) + (cond + [(current-emit) => (lambda (f) (f ev))] + [else (error 'emit "outside of general-event-processor")])) + (define (select-proc . clauses) + (cond + [(current-select) => (lambda (f) (apply f clauses))] + [else (error 'select "outside of general-event-processor")])) + + (define-syntax (select stx) + (syntax-case stx () + [(select clause ...) + (with-syntax ([((e k) ...) + (map (lambda (c) + (syntax-case c (=>) + [(e => k) #'(e k)] + [(e exp0 exp1 ...) #'(e (lambda (_) exp0 exp1 ...))])) + (syntax-e #'(clause ...)))]) + #'(select-proc (list e k) ...))])) + + (define (flush . strs) + (select-proc (map (lambda (str) (list str void)) strs))) + + (define (general-event-processor2 proc) + (do-in-manager + (let* ([out (econs undefined undefined)] + [emit (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val)] + [streams (make-hash-table 'weak)] + [extracted (make-hash-table 'weak)] + [top-esc #f] + [rtn (proc->signal void)] + [select (lambda e/k-list + (let/ec esc + (let loop () + (for-each (lambda (e/k) + (let* ([e (first e/k)] + [x (hash-table-get + extracted e + (lambda () empty))]) + (when (cons? x) + (hash-table-put! + extracted e (rest x)) + (esc ((second e/k) (first x)))))) + e/k-list) + (for-each (lambda (e/k) + (let* ([e (first e/k)]) + (hash-table-get + streams e + (lambda () + (register rtn e) + (hash-table-put! + streams e + (signal-value e)))))) + e/k-list) + (let/cc k + (set! proc (lambda () (k (void)))) + (top-esc (void))) + (loop))))]) + (let ([thunk (lambda () + (hash-table-for-each + streams + (lambda (k v) + ;; inefficient! appends each new event individually + (let loop ([str v]) + (when (and (econs? str) + (not (undefined? (erest str)))) + (hash-table-put! + extracted k + (append (hash-table-get extracted k (lambda () empty)) + (list (efirst (erest str))))) + (loop (erest str)))) + (hash-table-put! streams k (signal-value k)))) + (let/cc k + (set! top-esc k) + (parameterize ([current-emit emit] + [current-select select]) + (proc))) + out)]) + (set-signal-thunk! rtn thunk) + (iq-enqueue rtn) + rtn)))) (define (event-processor proc . args) (let* ([out (econs undefined undefined)] @@ -546,7 +632,27 @@ out)]) (apply proc->signal thunk args))) + ;; split : event[a] (a -> b) -> (b -> event[a]) + (define (split ev fn) + (let* ([ht (make-hash-table 'weak)] + [sig (map-e (lambda (e) + (let/ec k + (send-event + (hash-table-get ht (fn e) (lambda () (k (void)))) + e))) + ev)]) + (lambda (x) + sig + (hash-table-get + ht x (lambda () + (let ([rtn (event-receiver)]) + (hash-table-put! ht x rtn) + rtn)))))) + (define-syntax event-select + (syntax-rules () + [(_ [ev k] ...) + ()])) ;;;;;;;;;;;;;;;;;;;;;; ;; Command Lambda @@ -678,6 +784,9 @@ nothing nothing? general-event-processor + general-event-processor2 + emit + select event-processor switch merge-e @@ -719,6 +828,7 @@ mk-command-lambda until event-loop + split ;; from frp-core event-receiver