From 20eba81d8598a19deff78a6feeb0fdf579953841 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 20 Aug 2013 14:32:53 -0600
Subject: [PATCH] racket/gui: add 'disallow-invalid style to
 `get-text-from-user'

original commit: 0ecd04787aec941f5f6683159a80fdc3c5c0ee86
---
 .../scribblings/gui/dialog-funcs.scrbl        |  8 ++++---
 .../gui-lib/mred/private/moredialogs.rkt      | 22 +++++++++++++------
 2 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl b/pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl
index c308821a..06349849 100644
--- a/pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl
+++ b/pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl
@@ -391,7 +391,7 @@ Like @racket[message-box/custom], except that
                              [message (or/c label-string? #f)]
                              [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
                              [init-val string? ""]
-                             [style (listof 'password) null]
+                             [style (listof (or/c 'password 'disallow-invalid)) null]
                              [#:validate validate (-> string? boolean?)]
                              [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) 
          (or/c string? #f)]{
@@ -410,8 +410,10 @@ If @racket[style] includes @racket['password], the dialog's text field
  of the actual character.
 
 The @racket[validate] function is called each time the text field changed,
-with the contents of the text field. If it returns @racket[#t], the background
-of the text is colored pink.
+with the contents of the text field. If it returns @racket[#f], the background
+of the text is colored pink. If @racket['disallow-invalid] is included in
+@racket[style], the @onscreen{Ok} button is disabled whenever the text
+background is pink.
  
 The @racket[dialog-mixin] argument is applied to the class that implements the dialog
 before the dialog is created. 
diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt
index d3bc8c06..66bf96ae 100644
--- a/pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt
+++ b/pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt
@@ -195,7 +195,7 @@
     (check-label-string/false 'get-text-from-user message)
     (check-top-level-parent/false 'get-text-from-user parent)
     (check-string 'get-text-from-user init-val)
-    (check-style 'get-text-from-user #f '(password) style)
+    (check-style 'get-text-from-user #f '(password disallow-invalid) style)
     (define f (make-object (dialog-mixin dialog%) title parent box-width))
     (define ok? #f)
     (define (done ?) (set! ok? ?) (send f show #f))
@@ -208,22 +208,30 @@
                                   (done #t)]
                                  [else (do-validation)]))]
                    [init-value init-val]
-                   [style (list* 'single 'vertical-label style)]))
+                   [style (list* 'single 'vertical-label
+                                 (if (memq 'password style)
+                                     '(password)
+                                     '()))]))
     (define default-background (send t get-field-background))
     (define (do-validation)
+      (define valid? (validate (send t get-value)))
       (send t set-field-background 
-            (if (validate (send t get-value))
+            (if valid?
                 default-background
-                (send wx:the-color-database find-color "pink"))))
+                (send wx:the-color-database find-color "pink")))
+      (when (memq 'disallow-invalid style)
+        (send ok-button enable valid?)))
     (define p (make-object horizontal-pane% f))
     (send p set-alignment 'right 'center)
     (send f stretchable-height #f)
-    (ok-cancel
-     (lambda () (make-object button% "OK" p (λ (b e) (done #t)) '(border)))
-     (lambda () (make-object button% "Cancel" p (λ (b e) (done #f)))))
+    (define-values (ok-button cancel-button)
+      (ok-cancel
+       (lambda () (make-object button% "OK" p (λ (b e) (done #t)) '(border)))
+       (lambda () (make-object button% "Cancel" p (λ (b e) (done #f))))))
     (send (send t get-editor) select-all)
     (send t focus)
     (send f center)
+    (do-validation)
     (send f show #t)
     (and ok? (send t get-value)))