From 2084b187291146b11c8b9445e38cfa59043459e0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 6 Sep 2002 23:13:19 +0000
Subject: [PATCH] ..

original commit: 6bf3adf1b52e6687c3dbb21386a1e5aaab7d92b7
---
 collects/framework/gui-utils.ss | 152 +++++++-------------------------
 1 file changed, 30 insertions(+), 122 deletions(-)

diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss
index c7f823bc..728f7f33 100644
--- a/collects/framework/gui-utils.ss
+++ b/collects/framework/gui-utils.ss
@@ -660,65 +660,21 @@
   
   (define unsaved-warning
     (opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
-      (let* ([result 'cancel]
-             [unsaved-dialog%
-              (class dialog%
-                (inherit show center)
-                
-                (define/private (on-dont-save)
-                  (set! result 'continue)
-                  (show #f))
-                (define/private (on-save-now)
-                  (set! result 'save)
-                  (show #f))
-                (define/private (on-cancel)
-                  (set! result 'cancel)
-                  (show #f))
-                
-                (super-make-object (string-constant warning) parent)
-                
-                (let* ([outer-panel (make-object horizontal-panel% this)]
-                       [warning-msg (make-object message% 'caution outer-panel)]
-                       [panel (make-object vertical-panel% outer-panel)]
-                       [msg
-                        (make-object message%
-                          (format (string-constant file-is-not-saved) filename)
-                          panel)]
-                       [button-panel
-                        (make-object horizontal-panel% panel)]
-                       [anyway (make-object button% 
-                                 (string-append action-anyway)
-                                 button-panel
-                                 (lambda (x y) (on-dont-save)))]
-                       [now (make-object button% 
-                              (string-constant save)
-                              button-panel
-                              (lambda (x y) (on-save-now))
-                              (if can-save-now?
-                                  '(border)
-                                  '()))]
-                       [cancel (make-object button%
-                                 (string-constant cancel)
-                                 button-panel
-                                 (lambda (x y) (on-cancel))
-                                 (if can-save-now?
-                                     '()
-                                     '(border)))])
-                    (send button-panel change-children
-                          (lambda (l)
-                            (if (cancel-on-right?)
-                                (list anyway now cancel)
-                                (list anyway cancel now))))
-                    (if can-save-now?
-                        (send now focus)
-                        (begin (send cancel focus)
-                               (send now show #f)))
-                  
-                  (center 'both)
-                  
-                  (show #t)))])
-        (make-object unsaved-dialog%)
-        result)))
+      (let ([mb-res (message-box/custom 
+                     (string-constant warning)
+                     (format (string-constant file-is-not-saved) filename)
+                     (string-constant save)
+                     (string-constant cancel)
+                     action-anyway
+                     parent
+                     (if can-save-now?
+                         '(default=1)
+                         '(default=2))
+                     2)])
+        (case mb-res
+          [(1) 'save]
+          [(2) 'cancel]
+          [(3) 'continue]))))
   
   (define get-choice
     (opt-lambda (message 
@@ -727,69 +683,21 @@
                  (title (string-constant warning))
                  (default-result 'disallow-close)
                  (parent #f))
-      (letrec ([result default-result]
-               [dialog (make-object 
-                           (class dialog%
-                             (rename [super-on-close on-close]
-                                     [super-can-close? can-close?])
-                             (define/override (can-close?)
-                               (cond
-                                 [(eq? default-result 'disallow-close)
-                                  (bell)
-                                  (message-box title
-                                               (format (string-constant please-choose-either)
-                                                       true-choice false-choice))
-                                  #f]
-                                 [else
-                                  (super-can-close?)]))
-                             (define/override (on-close)
-                               (set! result default-result)
-                               (super-on-close))
-                             (super-make-object title parent)))]
-               [on-true
-                (lambda args
-                  (set! result #t)
-                  (send dialog show #f))]
-               [on-false
-                (lambda rags
-                  (set! result #f)
-                  (send dialog show #f))]
-               [vp (make-object vertical-panel% dialog)]
-               [hp (make-object horizontal-panel% dialog)])
-        
-        (if ((string-length message) . < . 200)
-            (let loop ([m message])
-              (let ([match (regexp-match (format "^([^~n]*)~n(.*)")
-                                         m)])
-                (if match
-                    (begin (make-object message% (cadr match) vp)
-                           (loop (caddr match)))
-                    (make-object message% m vp))))
-            (let* ([t (make-object text%)]
-                   [ec (make-object editor-canvas% vp t)])
-              (send ec min-width 400)
-              (send ec min-height 200)
-              (send t insert message)
-	      (send t set-position 0)
-              (send t auto-wrap #t)
-              (send t lock #t)))
-        
-        (send vp set-alignment 'left 'center)
-        (send hp set-alignment 'right 'center)
-        (let ([make-true
-               (lambda ()
-                 (send (make-object button% true-choice hp on-true '(border)) focus))]
-              [make-false
-               (lambda ()
-                 (make-object button% false-choice hp on-false))])
-          (if (cancel-on-right?)
-              (begin (make-true) (make-false))
-              (begin (make-false) (make-true))))
-        (send hp stretchable-height #f)
-        (send dialog center 'both)
-        (send dialog show #t)
-        result)))
- 
+      (let ([mb-res (message-box/custom
+                     title
+                     message
+                     true-choice
+                     false-choice
+                     #f
+                     parent
+                     (case default-result
+                       [(disallow-close) '(default=1 disallow-close)]
+                       [else '(default=1)])
+                     default-result)])
+        (case mb-res
+          [(1) #t]
+          [(2) #f]
+          [else mb-res])))) 
   
   ;; manual renaming
   (define gui-utils:next-untitled-name next-untitled-name)