From 5a12fc1492962af1a6dffc3d2eb3507b2bf59c70 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 10 Jun 2002 20:39:55 +0000
Subject: [PATCH] ..

original commit: 024a1a90247703e7eb35512274fd31c0cae673ff
---
 collects/framework/gui-utils.ss               | 237 +++++++++++-------
 collects/framework/private/frame.ss           |   2 -
 collects/framework/private/group.ss           | 102 ++++----
 collects/framework/private/main.ss            |   1 +
 collects/framework/private/preferences.ss     |  14 +-
 .../tests/framework/framework-test-engine.ss  |   1 +
 6 files changed, 202 insertions(+), 155 deletions(-)

diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss
index 4362747a..c29641e2 100644
--- a/collects/framework/gui-utils.ss
+++ b/collects/framework/gui-utils.ss
@@ -11,6 +11,41 @@
        (syntax (provide/contract (name contract) ...))]))
   
   (provide/contract/docs
+   
+   (gui-utils:cancel-on-right?
+    (-> boolean?)
+    ()
+    "Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
+    "in a dialog and \\scheme{#f} otherwise."
+    ""
+    "See also"
+    "@flink gui-utils:ok/cancel-buttons %"
+    ".")
+   (gui-utils:ok/cancel-buttons
+    (opt->*
+     ((is-a?/c area-container<%>)
+      ((is-a?/c button%) (is-a?/c event%) . -> . any)
+      ((is-a?/c button%) (is-a?/c event%) . -> . any))
+     (string?
+      string?)
+     ((is-a?/c button%)
+      (is-a?/c button%)))
+    ((parent
+      confirm-callback
+      cancel-callback)
+     ((confirm-label (string-constant ok))
+      (cancel-label (string-constant cancel))))
+    "Adds an Ok and a cancel button to a panel, changing the order"
+    "to suit the platform. Under MacOS and unix, the confirmation action"
+    "is on the right (or bottom) and under Windows, the canceling action is on the"
+    "right (or bottom)."
+    "The confirmation action button has the \\scheme|'(border)| style."
+    "The buttons are also sized to be the same width."
+    ""
+    "See also"
+    "@flink gui-utils:cancel-on-right? %"
+    ".")
+   
    (gui-utils:next-untitled-name
     (-> string?)
     ()
@@ -142,9 +177,12 @@
     "The argument \\var{default-result} determines how closing the window is"
     "treated. If the argument is \rawscm{'disallow-close}, closing the window"
     "is not allowed. If it is anything else, that value is returned when"
-    "the user closes the window.")
-
-   ;; (gui-utils:open-input-buffer any?) ;; who uses this?!?!
+    "the user closes the window."
+    ""
+    "If "
+    "@flink gui-utils:cancel-on-right?"
+    "returns \\scheme|#t|, the false choice is on the right."
+    "Otherwise, the true choice is on the right.")
 
    (gui-utils:get-clicked-clickback-delta
     (-> (is-a?/c style-delta%))
@@ -172,6 +210,38 @@
     "@flink gui-utils:get-clicked-clickback-delta %"
     "."))
   
+  (define (cancel-on-right?) (eq? (system-type) 'windows))
+  
+  (define ok/cancel-buttons
+    (opt-lambda (parent 
+                 confirm-callback
+                 cancel-callback 
+                 [confirm-str (string-constant ok)]
+                 [cancel-str (string-constant cancel)])
+      (let ([confirm (lambda ()
+                       (instantiate button% ()
+                         (parent parent)
+                         (callback confirm-callback)
+                         (label confirm-str)
+                         (style '(border))))]
+            [cancel (lambda ()
+                      (instantiate button% ()
+                        (parent parent)
+                        (callback cancel-callback)
+                        (label cancel-str)))])
+        (let-values ([(b1 b2)
+                      (cond
+                        [(cancel-on-right?)
+                         (values (confirm) (cancel))]
+                        [else
+                         (values (cancel) (confirm))])])
+          (let ([w (max (send b1 get-width)
+                        (send b2 get-width))])
+            (send b1 min-width w)
+            (send b2 min-width w)
+            (values b1 b2))))))
+
+  
   (define clickback-delta (make-object style-delta% 'change-underline #t))
   (send clickback-delta set-delta-foreground "BLUE")
   (define (get-clickback-delta) clickback-delta)
@@ -243,63 +313,64 @@
                (lambda () (cursor-off))))])))
   
   (define unsaved-warning
-    (case-lambda
-      [(filename action-anyway) (unsaved-warning filename action-anyway #f)]
-      [(filename action-anyway can-save-now?) (unsaved-warning filename action-anyway can-save-now? #f)]
-      [(filename action-anyway can-save-now? parent)
-       (let* ([result (void)]
-              [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* ([panel (make-object vertical-panel% this)]
-                        [msg
-                         (make-object message%
-                           (format (string-constant file-is-not-saved) filename)
-                           panel)]
-                        [button-panel
-                         (make-object horizontal-panel% panel)])
-                   (make-object button% 
-                     (string-append action-anyway)
-                     button-panel
-                     (lambda (x y) (on-dont-save)))
-                   
-                   (let ([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)))])
-                     (if can-save-now?
-                         (send now focus)
-                         (begin (send cancel focus)
-                                (send now show #f))))
-                   
-                   (center 'both)
-                   
-                   (show #t)))])
-         (make-object unsaved-dialog%)
-         result)]))
+    (opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
+      (let* ([result (void)]
+             [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* ([panel (make-object vertical-panel% this)]
+                       [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)))
   
   (define get-choice
     (opt-lambda (message 
@@ -356,41 +427,20 @@
         
         (send vp set-alignment 'left 'center)
         (send hp set-alignment 'right 'center)
-        (send (make-object button% true-choice hp on-true '(border)) focus)
-        (make-object button% false-choice hp on-false)
+        (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)))
-  
-  (define open-input-buffer
-    (lambda (buffer)
-      (let ([pos 0]
-            [lock (make-semaphore 1)])
-        (make-custom-input-port
-         lock
-         (lambda (s)
-           (if (semaphore-try-wait? lock)
-               (dynamic-wind
-                void
-                (lambda ()
-                  (let* ([len (send buffer last-position)]
-                         [count (min (string-length s)
-                                     (- len pos))])
-                    (if (zero? count)
-                        eof
-                        (let ([got (send buffer get-text pos (+ pos count))])
-                          (let loop ([count count])
-                            (unless (zero? count)
-                              (let ([count (sub1 count)])
-                                (string-set! s count (string-ref got count))
-                                (loop (sub1 count)))))
-                          (set! pos (+ pos count))
-                          count))))
-                (lambda () (semaphore-post lock)))
-               0))
-         #f
-         void))))
+ 
   
   ;; manual renaming
   (define gui-utils:next-untitled-name next-untitled-name)
@@ -399,6 +449,7 @@
   (define gui-utils:local-busy-cursor local-busy-cursor)
   (define gui-utils:unsaved-warning unsaved-warning)
   (define gui-utils:get-choice get-choice)
-  (define gui-utils:open-input-buffer open-input-buffer)
   (define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
-  (define gui-utils:get-clickback-delta get-clickback-delta))
+  (define gui-utils:get-clickback-delta get-clickback-delta)
+  (define gui-utils:ok/cancel-buttons ok/cancel-buttons)
+  (define gui-utils:cancel-on-right? cancel-on-right?))
\ No newline at end of file
diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss
index 41b85f31..3e74d6b5 100644
--- a/collects/framework/private/frame.ss
+++ b/collects/framework/private/frame.ss
@@ -95,8 +95,6 @@
           
           (make-object c% (string-constant insert-text-box-item)
             edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand)
-          (make-object c% (string-constant insert-pb-box-item)
-            edit-menu (edit-menu:do 'insert-pasteboard-box) #f #f on-demand)
           (make-object c% (string-constant insert-image-item)
             edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
           (void)))
diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss
index 18215389..6f510d1b 100644
--- a/collects/framework/private/group.ss
+++ b/collects/framework/private/group.ss
@@ -1,3 +1,4 @@
+
 (module group mzscheme
   (require (lib "string-constant.ss" "string-constants")
            (lib "unitsig.ss")
@@ -298,59 +299,54 @@
           (super-instantiate ())))
       
       (define (choose-a-frame parent)
-        (letrec ([sorted-frames
-                  (quicksort
-                   (send (get-the-frame-group) get-frames)
-                   (lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
-                 [d (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
-                 [lb (instantiate list-box% () 
-                       (label #f)
-                       (choices (map (lambda (x) (send x get-label)) sorted-frames))
-                       (callback (lambda (x y) (listbox-callback y)))
-                       (parent d))]
-                 [t (instantiate text:hide-caret/selection% ())]
-                 [ec (instantiate canvas:basic% ()
-                       (parent d)
-                       (stretchable-height #f))]
-                 [bp (instantiate horizontal-panel% ()
-                       (parent d)
-                       (stretchable-height #f)
-                       (alignment '(right center)))]
-                 [cancelled? #t]
-                 [ok (instantiate button% ()
-                       (label (string-constant ok))
-                       (parent bp)
-                       (callback (lambda (x y)
-                                   (set! cancelled? #f)
-                                   (send d show #f)))
-                       (style '(border)))]
-                 [cancel (instantiate button% ()
-                           (label (string-constant cancel))
-                           (parent bp) 
-                           (callback 
-                            (lambda (x y)
-                              (send d show #f))))]
-                 [listbox-callback
-                  (lambda (evt)
-                    (case (send evt get-event-type)
-                      [(list-box)
-                       
-                       (send ok enable (pair? (send lb get-selections)))
-                       
-                       (let ([full-name
-                              (let ([sels (send lb get-selections)])
-                                (and (pair? sels)
-                                     (let ([fr (list-ref sorted-frames (car sels))])
-                                       (and (is-a? fr frame:basic%)
-                                            (send fr get-filename)))))])
-                         (send t begin-edit-sequence)
-                         (send t erase)
-                         (when full-name
-                           (send t insert full-name))
-                         (send t end-edit-sequence))]
-                      [(list-box-dclick)
-                       (set! cancelled? #f)
-                       (send d show #f)]))])
+        (letrec-values ([(sorted-frames)
+                         (quicksort
+                          (send (get-the-frame-group) get-frames)
+                          (lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
+                        [(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
+                        [(lb) (instantiate list-box% () 
+                              (label #f)
+                              (choices (map (lambda (x) (send x get-label)) sorted-frames))
+                              (callback (lambda (x y) (listbox-callback y)))
+                              (parent d))]
+                        [(t) (instantiate text:hide-caret/selection% ())]
+                        [(ec) (instantiate canvas:basic% ()
+                              (parent d)
+                              (stretchable-height #f))]
+                        [(bp) (instantiate horizontal-panel% ()
+                              (parent d)
+                              (stretchable-height #f)
+                              (alignment '(right center)))]
+                        [(cancelled?) #t]
+                        [(listbox-callback)
+                         (lambda (evt)
+                           (case (send evt get-event-type)
+                             [(list-box)
+                              
+                              (send ok enable (pair? (send lb get-selections)))
+                              
+                              (let ([full-name
+                                     (let ([sels (send lb get-selections)])
+                                       (and (pair? sels)
+                                            (let ([fr (list-ref sorted-frames (car sels))])
+                                              (and (is-a? fr frame:basic%)
+                                                   (send fr get-filename)))))])
+                                (send t begin-edit-sequence)
+                                (send t erase)
+                                (when full-name
+                                  (send t insert full-name))
+                                (send t end-edit-sequence))]
+                             [(list-box-dclick)
+                              (set! cancelled? #f)
+                              (send d show #f)]))]
+                        [(ok cancel)
+                         (gui-utils:ok/cancel-buttons
+                          bp
+                          (lambda (x y)
+                            (set! cancelled? #f)
+                            (send d show #f))
+                          (lambda (x y)
+                            (send d show #f)))])
           (send ec set-line-count 3)
           (send ec set-editor t)
           (send t auto-wrap #t)
diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss
index 33660afb..68d21fef 100644
--- a/collects/framework/private/main.ss
+++ b/collects/framework/private/main.ss
@@ -17,6 +17,7 @@
 	      [group : framework:group^])
       
       ;; preferences
+      (preferences:set-default 'framework:last-url-string "" string?)
       (preferences:set-default 'framework:recently-opened-sort-by 'age 
                                (lambda (x) (or (eq? x 'age) (eq? x 'name))))
       (preferences:set-default 'framework:recent-items-window-w 400 number?)
diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss
index 2570e559..da6197d7 100644
--- a/collects/framework/private/preferences.ss
+++ b/collects/framework/private/preferences.ss
@@ -6,6 +6,7 @@
            (lib "file.ss")
 	   (lib "class100.ss")
 	   "sig.ss"
+           "../gui-utils.ss"
 	   (lib "mred-sig.ss" "mred")
 	   (lib "pretty.ss")
 	   (lib "list.ss"))
@@ -731,15 +732,14 @@
                    [ok-callback (lambda args
                                   (save)
                                   (hide-dialog))]
-                   [ok-button (make-object button% (string-constant ok)
-                                bottom-panel ok-callback '(border))]
                    [cancel-callback (lambda (_1 _2)
                                       (hide-dialog)
-                                      (install-stashed-preferences stashed-prefs))]
-                   [cancel-button (make-object button% (string-constant cancel)
-                                    bottom-panel cancel-callback)]
-                   [grow-box-space (make-object grow-box-spacer-pane% bottom-panel)])
-            (send ok-button min-width (send cancel-button get-width))
+                                      (install-stashed-preferences stashed-prefs))])
+            (gui-utils:ok/cancel-buttons
+             bottom-panel
+             cancel-callback
+             ok-callback)
+            (make-object grow-box-spacer-pane% bottom-panel)
             (send* bottom-panel
               (stretchable-height #f)
               (set-alignment 'right 'center))
diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss
index c2c04a52..10a4e89a 100644
--- a/collects/tests/framework/framework-test-engine.ss
+++ b/collects/tests/framework/framework-test-engine.ss
@@ -1,3 +1,4 @@
+
 (module framework-test-engine mzscheme
   (require (lib "pconvert.ss")
 	   (lib "mred.ss" "mred")