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

..

Browse Source 
original commit: d94cda19374b41803f9a70d1cb9582c52fae5428
This commit is contained in:
Robby Findler 2003-02-25 18:41:56 +00:00
parent 6adf352ebf
commit ef1d37527c
1 changed files with 30 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/framework/private/frame.ss
View File

@ -315,7 +315,6 @@
(do-main-thread (do-main-thread
(lambda () (lambda ()
(when status-line-container-panel (when status-line-container-panel
(printf "open-status-line.1: ~s ~a\n" id (length status-lines))
(set! status-lines (set! status-lines
(let loop ([status-lines status-lines]) (let loop ([status-lines status-lines])
(cond (cond
@ -325,14 +324,12 @@
(if (eq? id (status-line-id status-line)) (if (eq? id (status-line-id status-line))
(cons (make-status-line id (+ (status-line-count status-line) 1)) (cons (make-status-line id (+ (status-line-count status-line) 1))
(cdr status-lines)) (cdr status-lines))
(cons status-line (loop (cdr status-lines)))))]))) (cons status-line (loop (cdr status-lines)))))])))))))
(printf "open-status-line.2: ~s ~a\n" id (length status-lines))))))
(define/public (close-status-line id) (define/public (close-status-line id)
(do-main-thread (do-main-thread
(lambda () (lambda ()
(when status-line-container-panel (when status-line-container-panel
(printf "close-status-line.1: ~s ~s ~s\n" id (length status-lines) (length status-line-msgs))
;; decrement counter in for status line, or remove it if ;; decrement counter in for status line, or remove it if
;; counter goes to zero. ;; counter goes to zero.
@ -351,33 +348,38 @@
[else (cons status-line (loop (cdr status-lines)))]))]))) [else (cons status-line (loop (cdr status-lines)))]))])))
;; make sure that there are only as many messages as different status lines, in total ;; make sure that there are only as many messages as different status lines, in total
(update-statue-line id #f) (let ([status-line-msg (find-status-line-msg id)])
(let ([msgs-that-can-be-removed (filter (lambda (x) (not (status-line-msg-id x))) status-line-msgs-id)] (when status-line-msg
[max-to-include (length status-line-msgs)] (send (status-line-msg-message status-line-msg) set-label "")
(let loop ( (set-status-line-msg-id! status-line-msg #f)))
(set! status-line-msgs (let* ([msgs-that-can-be-removed (filter (lambda (x) (not (status-line-msg-id x))) status-line-msgs)]
(let loop ([status-lines status-lines] [max-to-include (length status-lines)]
[status-line-msgs status-line-msgs]) [msgs-to-remove
(cond (let loop ([n max-to-include]
[(null? status-line-msgs) null] [l msgs-that-can-be-removed])
[(null? status-lines) (cond
(send status-line-container-panel [(null? l) l]
change-children [(zero? n) l]
(lambda (l) [else (loop (- n 1) (cdr l))]))])
(foldl (lambda (status-line-msg l) (send status-line-container-panel
(remq (status-line-msg-message status-line-msg) l)) change-children
l (lambda (old-children)
status-line-msgs))) (foldl (lambda (status-line-msg l)
null] (remq (status-line-msg-message status-line-msg) l))
[else (loop (cdr status-lines) (cdr status-line-msgs))]))) old-children
msgs-to-remove)))
(printf "close-status-line.2: ~s ~s ~s\n" id (length status-lines) (length status-line-msgs)))))) (set! status-line-msgs
(let loop ([l msgs-to-remove]
[status-line-msgs status-line-msgs])
(cond
[(null? l) status-line-msgs]
[else (loop (cdr l)
(remq (car l) status-line-msgs))]))))))))
;; update-status-line : symbol (union #f string) ;; update-status-line : symbol (union #f string)
(define/public (update-status-line id msg-txt) (define/public (update-status-line id msg-txt)
(do-main-thread (do-main-thread
(lambda () (lambda ()
(printf "update-status-line: ~a ~s\n" id msg-txt)
(unless (open-status-line? id) (unless (open-status-line? id)
(error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt)) (error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt))
(if msg-txt (if msg-txt
@ -447,7 +449,8 @@
(if (eq? (current-thread) eventspace-main-thread) (if (eq? (current-thread) eventspace-main-thread)
(t) (t)
(parameterize ([current-eventspace (get-eventspace)]) (parameterize ([current-eventspace (get-eventspace)])
(queue-callback t #f)))) ;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t))))
(super-instantiate ()))) (super-instantiate ())))