78 lines
2.1 KiB
Scheme
78 lines
2.1 KiB
Scheme
(module exit mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "class.ss")
|
|
"sig.ss"
|
|
"../gui-utils.ss"
|
|
(lib "mred-sig.ss" "mred")
|
|
(lib "file.ss")
|
|
(lib "etc.ss"))
|
|
|
|
(provide exit@)
|
|
|
|
(define exit@
|
|
(unit/sig framework:exit^
|
|
(import mred^
|
|
[preferences : framework:preferences^])
|
|
(rename (-exit exit))
|
|
|
|
(define frame-exiting (make-parameter #f))
|
|
|
|
(define can?-callbacks '())
|
|
(define on-callbacks '())
|
|
|
|
(define insert-can?-callback
|
|
(lambda (cb)
|
|
(set! can?-callbacks (cons cb can?-callbacks))
|
|
(lambda ()
|
|
(set! can?-callbacks
|
|
(let loop ([cb-list can?-callbacks])
|
|
(cond
|
|
[(null? cb-list) ()]
|
|
[(eq? cb (car cb-list)) (cdr cb-list)]
|
|
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
|
|
|
(define insert-on-callback
|
|
(lambda (cb)
|
|
(set! on-callbacks (cons cb on-callbacks))
|
|
(lambda ()
|
|
(set! on-callbacks
|
|
(let loop ([cb-list on-callbacks])
|
|
(cond
|
|
[(null? cb-list) ()]
|
|
[(eq? cb (car cb-list)) (cdr cb-list)]
|
|
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
|
|
|
|
(define exiting? #f)
|
|
|
|
(define can-exit?
|
|
(opt-lambda ([skip-user-query? #f])
|
|
(and (or skip-user-query?
|
|
(user-oks-exit))
|
|
(andmap (lambda (cb) (cb)) can?-callbacks))))
|
|
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
|
|
|
|
(define (user-oks-exit)
|
|
(if (preferences:get 'framework:verify-exit)
|
|
(gui-utils:get-choice
|
|
(if (eq? (system-type) 'windows)
|
|
(string-constant are-you-sure-exit)
|
|
(string-constant are-you-sure-quit))
|
|
(if (eq? (system-type) 'windows)
|
|
(string-constant exit)
|
|
(string-constant quit))
|
|
(string-constant cancel)
|
|
(string-constant warning)
|
|
#f
|
|
(frame-exiting))
|
|
#t))
|
|
|
|
(define -exit
|
|
(opt-lambda ([skip-user-query? #f])
|
|
(unless exiting?
|
|
(set! exiting? #t)
|
|
(when (can-exit? skip-user-query?)
|
|
(on-exit)
|
|
(queue-callback (lambda () (exit))))
|
|
(set! exiting? #f)))))))
|