https://alex-hhh.github.io/2018/11/an-enhanced-text-field-gui-control-for-racket.html

enhanced-text-input.rkt

#lang racket/gui
;; Copyright (c) 2018 Alex Harsanyi

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.

(require racket/date)

(define (string->date str)
  (let* ([t (string-trim str)]
         [m (regexp-match "^([0-9]+)/([0-9]+)/([0-9]+)$" t)])
    (and m
         (let ((day (string->number (list-ref m 1)))
               (month (string->number (list-ref m 2)))
               (year (string->number (list-ref m 3))))
           (with-handlers (((lambda (e) #t) (lambda (e) #f)))
             (find-seconds 0 0 0 day month year))))))

(define (date->string seconds)
  (define date (seconds->date seconds))
  (string-append
   (~a (date-day date) #:width 2 #:left-pad-string "0")
   "/"
   (~a (date-month date) #:width 2 #:left-pad-string "0")
   "/"
   (~a (date-year date) #:width 4 #:left-pad-string "0")))

(define (validating-mixin string->data data->string base-class)
  (unless (subclass? base-class text-field%)
    (error "validating-mixin: parent is not derived from text-field%"))
  (class base-class
    (init-field [allow-empty? #f])
    (super-new)

    (define good-bg (send this get-field-background))
    (define bad-bg (make-object color% 255 120 124)) ; red
    
    (define (valid-value? data)
      (let ([t (string-trim data)])
        (or (and allow-empty? (= (string-length t) 0)) (string->data t))))
    
    (define (validate)
      (let ([valid? (valid-value? (send this get-value))])
        (send this set-field-background (if valid? good-bg bad-bg))))

    (define/override (on-subwindow-char receiver event)
      (begin0 (super on-subwindow-char receiver event)
        (validate)))

    (define/override (set-value v)
      (super set-value (if (string? v) v (data->string v)))
      (validate))

    (define/public (get-converted-value)
      (let ([v (string-trim (send this get-value))])
        (and (valid-value? v)
             (if (= (string-length v) 0) 'empty (string->data v)))))

    (validate)))

(define cue-text-style
  (let ((grey-text (new style-delta%)))
    (send grey-text set-delta-foreground "gray")
    grey-text))

(define normal-text-style
  (let ((black-text (new style-delta%)))
    (send black-text set-delta-foreground "black")
    black-text))

(define (text-empty? a-text)
  (define snip (send a-text find-first-snip))
  (or (not snip) (= 0 (send snip get-count))))

(define (cue-mixin default-cue base-class)
  (unless (subclass? base-class text-field%)
    (error "cue-mixin: parent is not derived from text-field%"))
  (class base-class
    (init-field [cue default-cue] [callback #f])
    (super-new [callback (lambda (c e) (on-callback c e))])

    (define showing-cue? #f)
    (define editor (send this get-editor))

    (define (clear-cue)
      (when showing-cue?
        (send* editor
          (erase)
          (change-style normal-text-style 'start 'end #f))
        (set! showing-cue? #f)))

    (define (maybe-insert-cue)
      (unless (or showing-cue? (not (text-empty? editor)))
        (send* editor
          ;; NOTE; change-style will change *selected* text between start and
          ;; end, and make it sticky, so text inserted after 'end will also
          ;; have the same style.  It is simpler to start with an empty text,
          ;; apply the style and than insert the cue, otherwise we would have
          ;; to select the cue, apply the style and un-select it.
          (change-style cue-text-style 'start 'end #f)
          (insert cue)
          (move-position 'home))
        (set! showing-cue? #t)))

    (define/override (on-subwindow-char receiver event)
      (clear-cue)
      (begin0 (super on-subwindow-char receiver event)
        (queue-callback (lambda () (maybe-insert-cue)))))

    (define (on-callback control event)
      (when (and callback (not showing-cue?))
        (callback control event)))

    (define/override (set-value v)
      (clear-cue)
      (super set-value v)
      (maybe-insert-cue))

    (define/override (get-value)
      (if showing-cue? "" (super get-value)))

    (maybe-insert-cue)))

;; Use a bigger font for the dialog controls, looks nicer in screen shots
(define font (send the-font-list find-or-create-font 14 'default 'normal))

;; A dialog mixin for the `message-box` function to use bigger spacing between
;; items -- looks nicer.
(define (make-dialog-mixin %) (class % (init) (super-new [border 10] [spacing 10])))

(define toplevel (new frame% [label "Test Dialog"] [border 30] [spacing 30] [width 200]))

(define date-input-field%
  (validating-mixin string->date date->string (cue-mixin "DD/MM/YYYY" text-field%)))

(define input (new date-input-field%
                   [allow-empty? #t]
                   [label "Enter a date "]
                   [font font] [parent toplevel]))

;; The button callback is invoked when the button is pressed
(define (button-callback b e)
  (let ((text (send input get-value)))
    (if (string->date text)
        (message-box "OK" (format "Date is valid: ~a" text) toplevel '(no-icon ok)
                     #:dialog-mixin make-dialog-mixin)
        (message-box "Error" "Invalid Date, expecting DD/MM/YYYY" toplevel '(stop ok)
                     #:dialog-mixin make-dialog-mixin))))

(new button% [label "Check"]
     [parent toplevel]
     [font font]
     [callback button-callback])

(send toplevel show #t)