77 lines
2.2 KiB
Racket
77 lines
2.2 KiB
Racket
#lang scheme/unit
|
|
|
|
(require string-constants
|
|
"sig.rkt"
|
|
"../preferences.rkt"
|
|
"../gui-utils.rkt"
|
|
mred/mred-sig)
|
|
|
|
(import mred^)
|
|
(export (rename framework:exit^
|
|
(-exit exit)))
|
|
|
|
(define can?-callbacks '())
|
|
(define on-callbacks '())
|
|
|
|
(define insert-can?-callback
|
|
(λ (cb)
|
|
(set! can?-callbacks (cons cb can?-callbacks))
|
|
(λ ()
|
|
(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
|
|
(λ (cb)
|
|
(set! on-callbacks (cons cb on-callbacks))
|
|
(λ ()
|
|
(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 is-exiting? #f)
|
|
(define (set-exiting b) (set! is-exiting? b))
|
|
(define (exiting?) is-exiting?)
|
|
|
|
(define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks))
|
|
(define (on-exit) (for-each (λ (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))
|
|
(if (eq? (system-type) 'windows)
|
|
(string-constant dont-exit)
|
|
(string-constant dont-quit))
|
|
(string-constant warning)
|
|
#f
|
|
#f
|
|
'app
|
|
(case-lambda
|
|
[() (not (preferences:get 'framework:verify-exit))]
|
|
[(new) (preferences:set 'framework:verify-exit (not new))]))
|
|
#t))
|
|
|
|
(define (-exit)
|
|
(set! is-exiting? #t)
|
|
(cond
|
|
[(can-exit?)
|
|
(on-exit)
|
|
(queue-callback
|
|
(λ ()
|
|
(exit)
|
|
(set! is-exiting? #f)))]
|
|
[else
|
|
(set! is-exiting? #f)]))
|