.
original commit: f2fd45489cf4e6ff640a3d59ed0b91674b7f2971
This commit is contained in:
Robby Findler
parent
5f4e2ff5ef
commit
7486c4c96d
|
|
@ -63,7 +63,7 @@
|
|||
'text))))
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t)))
|
||||
(super-instantiate ())
|
||||
(super-new)
|
||||
(let ([seconds (preferences:get 'framework:autosave-delay)])
|
||||
(start (* 1000 seconds) #t))))
|
||||
|
||||
|
|
@ -134,11 +134,10 @@
|
|||
[filtered-table
|
||||
(filter (lambda (x) (file-exists? (cadr x))) table)])
|
||||
(unless (null? filtered-table)
|
||||
(let* ([f (make-object final-frame%
|
||||
(string-constant recover-autosave-files-frame-title))]
|
||||
[t (instantiate text% ()
|
||||
(auto-wrap #t))]
|
||||
[ec (instantiate editor-canvas% ()
|
||||
(let* ([f (new final-frame%
|
||||
(label (string-constant recover-autosave-files-frame-title)))]
|
||||
[t (new text% (auto-wrap #t))]
|
||||
[ec (new editor-canvas%
|
||||
(parent (send f get-area-container))
|
||||
(editor t)
|
||||
(line-count 2)
|
||||
|
|
@ -168,13 +167,14 @@
|
|||
|
||||
(define final-frame%
|
||||
(class frame:basic%
|
||||
(define/override (can-close?) #t)
|
||||
(define/override (on-close)
|
||||
(define/augment (can-close?) #t)
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(send (group:get-the-frame-group)
|
||||
remove-frame
|
||||
this)
|
||||
(semaphore-post done-semaphore))
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>))
|
||||
;; -> (list (union #f string[filename]) string[filename-file-exists?])
|
||||
|
|
@ -184,27 +184,27 @@
|
|||
(lambda (table-entry)
|
||||
(letrec ([orig-file (car table-entry)]
|
||||
[backup-file (cadr table-entry)]
|
||||
[hp (instantiate horizontal-panel% ()
|
||||
[hp (new horizontal-panel%
|
||||
(parent area-container)
|
||||
(style '(border))
|
||||
(stretchable-height #f))]
|
||||
[vp (instantiate vertical-panel% ()
|
||||
[vp (new vertical-panel%
|
||||
(parent hp))]
|
||||
[msg1-panel (instantiate horizontal-panel% ()
|
||||
[msg1-panel (new horizontal-panel%
|
||||
(parent vp))]
|
||||
[msg1-label (instantiate message% ()
|
||||
[msg1-label (new message%
|
||||
(parent msg1-panel)
|
||||
(label (string-constant autosave-original-label:)))]
|
||||
[msg1 (instantiate message% ()
|
||||
[msg1 (new message%
|
||||
(label (or orig-file (string-constant autosave-unknown-filename)))
|
||||
(stretchable-width #t)
|
||||
(parent msg1-panel))]
|
||||
[msg2-panel (instantiate horizontal-panel% ()
|
||||
[msg2-panel (new horizontal-panel%
|
||||
(parent vp))]
|
||||
[msg2-label (instantiate message% ()
|
||||
[msg2-label (new message%
|
||||
(parent msg2-panel)
|
||||
(label (string-constant autosave-autosave-label:)))]
|
||||
[msg2 (instantiate message% ()
|
||||
[msg2 (new message%
|
||||
(label backup-file)
|
||||
(stretchable-width #t)
|
||||
(parent msg2-panel))]
|
||||
|
|
@ -275,7 +275,7 @@
|
|||
#f
|
||||
(if file1 600 300)
|
||||
600))
|
||||
(define hp (instantiate horizontal-panel% ()
|
||||
(define hp (new horizontal-panel%
|
||||
(parent (send frame get-area-container))))
|
||||
(when file1
|
||||
(add-file-viewer file1 hp (string-constant autosave-original-label)))
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
|
||||
(define original-output-port (current-output-port))
|
||||
(define (printf . args)
|
||||
;(apply fprintf original-output-port args)
|
||||
(apply fprintf original-output-port args)
|
||||
(void))
|
||||
|
||||
(define-struct range (start end b/w-bitmap color caret-space?))
|
||||
|
|
@ -1186,7 +1186,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
;; loop : -> alpha
|
||||
;; the main loop for this thread
|
||||
(define (loop)
|
||||
(printf "loop ~s\n" (queue->list data))
|
||||
(let-values ([(not-ready-peekers new-peek-response-evts)
|
||||
(separate peekers service-waiter)]
|
||||
[(potential-commits new-commit-response-evts)
|
||||
|
|
@ -1202,13 +1201,11 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(handle-evt
|
||||
read-chan
|
||||
(lambda (ent)
|
||||
(printf "read-chan ~s\n" ent)
|
||||
(set! data (enqueue ent data))
|
||||
(loop)))
|
||||
(handle-evt
|
||||
clear-input-chan
|
||||
(lambda (_)
|
||||
(printf "clear-input-chan\n")
|
||||
(semaphore-post peeker-sema)
|
||||
(set! peeker-sema (make-semaphore 0))
|
||||
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
||||
|
|
@ -1217,7 +1214,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(handle-evt
|
||||
progress-event-chan
|
||||
(lambda (return-pr)
|
||||
(printf "progress-event ~s\n" return-pr)
|
||||
(let ([return-chan (car return-pr)]
|
||||
[return-nack (cdr return-pr)])
|
||||
(set! response-evts
|
||||
|
|
@ -1230,13 +1226,11 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
peek-chan
|
||||
(lambda (peeker)
|
||||
(print-struct #t)
|
||||
(printf "peek-chan ~s\n" peeker)
|
||||
(set! peekers (cons peeker peekers))
|
||||
(loop)))
|
||||
(handle-evt
|
||||
commit-chan
|
||||
(lambda (committer)
|
||||
(printf "commit-chan ~s\n" committer)
|
||||
(set! committers (cons committer committers))
|
||||
(loop)))
|
||||
(apply
|
||||
|
|
@ -1253,15 +1247,13 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(choice-evt
|
||||
(handle-evt
|
||||
commit-peeker-evt
|
||||
(lambda (_)
|
||||
(printf "commit-peeker-evt\n")
|
||||
(lambda (_)
|
||||
;; this committer will be thrown out in next iteration
|
||||
(loop)))
|
||||
(handle-evt
|
||||
done-evt
|
||||
(lambda (v)
|
||||
(set! data (dequeue-n data kr))
|
||||
(printf "done-evt ~s new data ~s\n" v (queue->list data))
|
||||
(semaphore-post peeker-sema)
|
||||
(set! peeker-sema (make-semaphore 0))
|
||||
(set! peeker-evt (semaphore-peek-evt peeker-sema))
|
||||
|
|
@ -1279,7 +1271,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(handle-evt
|
||||
resp-evt
|
||||
(lambda (_)
|
||||
(printf "resp-evt\n")
|
||||
(set! response-evts (remq resp-evt response-evts))
|
||||
(loop))))
|
||||
response-evts)))))
|
||||
|
|
@ -1332,12 +1323,10 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
[($ peeker bytes skip-count pe resp-chan nack-evt)
|
||||
(cond
|
||||
[(and pe (not (eq? pe peeker-evt)))
|
||||
(printf "peeker case 1 ~s ~s\n" pe peeker-evt)
|
||||
(choice-evt (channel-put-evt resp-chan #f)
|
||||
nack-evt)]
|
||||
[((queue-size data) . > . skip-count)
|
||||
(let ([nth (peek-n data skip-count)])
|
||||
(printf "peeker case 2 ~s\n" nth)
|
||||
(choice-evt
|
||||
nack-evt
|
||||
(cond
|
||||
|
|
@ -1352,7 +1341,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(lambda (src line col pos)
|
||||
nth))])))]
|
||||
[else
|
||||
(printf "peeker case 3\n")
|
||||
#f])]))
|
||||
|
||||
(loop))))
|
||||
|
|
@ -1365,7 +1353,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
;; in any thread (even concurrently)
|
||||
;;
|
||||
(define (read-bytes-proc bstr)
|
||||
(printf "(read-bytes-proc ~s)\n" bstr)
|
||||
(let* ([progress-evt (progress-evt-proc)]
|
||||
[v (peek-proc bstr 0 progress-evt)])
|
||||
(cond
|
||||
|
|
@ -1382,26 +1369,21 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
0))))])))
|
||||
|
||||
(define (peek-proc bstr skip-count progress-evt)
|
||||
(let ([ans (nack-guard-evt
|
||||
(lambda (nack)
|
||||
(let ([chan (make-channel)])
|
||||
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack))
|
||||
chan)))])
|
||||
(printf "~s -> ~s\n" (list 'peek-proc bstr skip-count progress-evt) ans)
|
||||
ans))
|
||||
(nack-guard-evt
|
||||
(lambda (nack)
|
||||
(let ([chan (make-channel)])
|
||||
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack))
|
||||
chan))))
|
||||
|
||||
(define (progress-evt-proc)
|
||||
(let ([ans (sync
|
||||
(nack-guard-evt
|
||||
(lambda (nack)
|
||||
(let ([chan (make-channel)])
|
||||
(channel-put progress-event-chan (cons chan nack))
|
||||
chan))))])
|
||||
(printf "~s -> ~s\n" (list 'progress-evt-proc) ans)
|
||||
ans))
|
||||
(sync
|
||||
(nack-guard-evt
|
||||
(lambda (nack)
|
||||
(let ([chan (make-channel)])
|
||||
(channel-put progress-event-chan (cons chan nack))
|
||||
chan)))))
|
||||
|
||||
(define (commit-proc kr progress-evt done-evt)
|
||||
(printf "~s\n" (list 'commit-proc kr progress-evt done-evt))
|
||||
(sync
|
||||
(nack-guard-evt
|
||||
(lambda (nack)
|
||||
|
|
@ -1441,7 +1423,6 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
|
||||
;; dequeue-n : queue number -> queue
|
||||
(define (dequeue-n queue n)
|
||||
(printf "~s\n" (list 'dequeue-n (queue->list queue) n))
|
||||
(let loop ([q queue]
|
||||
[n n])
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@
|
|||
(splash-load-handler old-load f expected))))
|
||||
|
||||
;; abstraction breaking -- matthew will change cm
|
||||
;; so that I don't need this here.
|
||||
;; so that I don't need this here(?).
|
||||
(when addl-load-handler
|
||||
(printf "PLTDRCM: reinstalling CM load handler after setting splash load handler\n")
|
||||
(current-load/use-compiled (addl-load-handler))))
|
||||
|
|
@ -187,10 +187,10 @@
|
|||
|
||||
(define splash-frame%
|
||||
(class frame%
|
||||
(define/override (on-close)
|
||||
(define/augment (on-close)
|
||||
(when quit-on-close?
|
||||
(exit)))
|
||||
(super-instantiate ())))
|
||||
(super-new)))
|
||||
|
||||
(define splash-canvas%
|
||||
(class canvas%
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user