1  #lang at-exp racket/base
  2  
  3  (require string-constants racket/gui/base
  4           racket/contract/base racket/class)
  5  (require scribble/srcdoc)
  6  (require/doc racket/base scribble/manual)
  7  
  8  (define (trim-string str size)
  9    (let ([str-size (string-length str)])
 10      (cond
 11        [(<= str-size size)
 12         str]
 13        [else
 14         (let* ([between "..."]
 15                [pre-length (- (quotient size 2)
 16                               (quotient (string-length between) 2))]
 17                [post-length (- size
 18                                pre-length
 19                                (string-length between))])
 20           (cond
 21             [(or (<= pre-length 0)
 22                  (<= post-length 0))
 23              (substring str 0 size)]
 24             [else
 25              (string-append
 26               (substring str 0 pre-length)
 27               between
 28               (substring str
 29                          (- str-size post-length)
 30                          str-size))]))])))
 31  
 32  
 33  (define maximum-string-label-length 200)
 34  
 35  ;; format-literal-label: string any* -> string
 36  (define (format-literal-label format-str . args)
 37    (quote-literal-label (apply format format-str args)))
 38  
 39  ;; quote-literal-label: string -> string
 40  (define (quote-literal-label a-str #:quote-amp? [quote-amp? #t])
 41    (define quoted (if quote-amp?
 42                       (regexp-replace* #rx"(&)" a-str "\\1\\1")
 43                       a-str))
 44    (trim-string quoted maximum-string-label-length))
 45  
 46  ;; selected-text-color : color
 47  (define selected-text-color (send the-color-database find-color "black"))
 48  
 49  ;; unselected-text-color : color
 50  (define unselected-text-color (case (system-type)
 51                                  [(macosx) (make-object color% 75 75 75)]
 52                                  [else (send the-color-database find-color "black")]))
 53  
 54  ;; selected-brush : brush
 55  (define selected-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
 56  
 57  ;; unselected-brush : brush
 58  (define unselected-brush (send the-brush-list find-or-create-brush (get-panel-background) 'solid))
 59  
 60  ;; button-down/over-brush : brush
 61  (define button-down/over-brush 
 62    (case (system-type)
 63      [(macosx) (send the-brush-list find-or-create-brush
 64                      "light blue"
 65                      'solid)]
 66      [else
 67       (send the-brush-list find-or-create-brush
 68             (make-object color% 225 225 255)
 69             'solid)]))
 70  
 71  
 72  ;; name-box-pen : pen
 73  ;; this pen draws the lines around each individual item
 74  (define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
 75  
 76  ;; background-brush : brush
 77  ;; this brush is set when drawing the background for the control
 78  (define background-brush 
 79    (case (system-type)
 80      [(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)]
 81      [else (send the-brush-list find-or-create-brush "white" 'solid)]))
 82  
 83  ;; background-pen : pen
 84  ;; this pen is set when drawing the background for the control
 85  (define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
 86  
 87  ;; label-font : font
 88  (define label-font (send the-font-list find-or-create-font
 89                           (if (eq? (system-type) 'windows) 10 12)
 90                           'system 'normal
 91                           (if (eq? (system-type) 'macosx) 'bold 'normal)
 92                           #f))
 93  
 94  ;; name-gap : number
 95  ;; the space between each name
 96  (define name-gap 4)
 97  
 98  ;; hang-over : number
 99  ;; the amount of space a single entry "slants" over
100  (define hang-over 8)
101  
102  ;; top-space : number
103  ;; the gap at the top of the canvas, above all the choices
104  (define top-space 4)
105  
106  ;; bottom-space : number
107  ;; the extra space below the words
108  (define bottom-space 2)
109  
110  ;; end choices-canvas%
111  
112  (define (cancel-on-right?) (system-position-ok-before-cancel?))
113  
114  (define (ok/cancel-buttons parent 
115                             confirm-callback
116                             cancel-callback 
117                             [confirm-str (string-constant ok)]
118                             [cancel-str (string-constant cancel)]
119                             #:confirm-style [confirm-style '(border)]) 
120    (let ([confirm (λ ()
121                     (instantiate button% ()
122                       (parent parent)
123                       (callback confirm-callback)
124                       (label confirm-str)
125                       (style confirm-style)))]
126          [cancel (λ ()
127                    (instantiate button% ()
128                      (parent parent)
129                      (callback cancel-callback)
130                      (label cancel-str)))])
131      (let-values ([(b1 b2)
132                    (cond
133                      [(cancel-on-right?)
134                       (values (confirm) (cancel))]
135                      [else
136                       (values (cancel) (confirm))])])
137        (let ([w (max (send b1 get-width)
138                      (send b2 get-width))])
139          (send b1 min-width w)
140          (send b2 min-width w)
141          (if (cancel-on-right?)
142              (values b1 b2)
143              (values b2 b1))))))
144  
145  
146  (define clickback-delta (make-object style-delta% 'change-underline #t))
147  (define white-on-black-clickback-delta (make-object style-delta% 'change-underline #t))
148  (let ()
149    (send clickback-delta set-delta-foreground "BLUE")
150    (send white-on-black-clickback-delta set-delta-foreground "deepskyblue")
151    (void))
152  (define get-clickback-delta
153    (lambda ([white-on-black? #f])
154      (if white-on-black? 
155          white-on-black-clickback-delta
156          clickback-delta)))
157  
158  (define clicked-clickback-delta (make-object style-delta%))
159  (define white-on-black-clicked-clickback-delta (make-object style-delta%))
160  (let ()
161    (send clicked-clickback-delta set-delta-background "BLACK")
162    (send white-on-black-clicked-clickback-delta set-delta-background "white")
163    (void))
164  (define get-clicked-clickback-delta
165    (lambda ([white-on-black? #f])
166      (if white-on-black? 
167          white-on-black-clicked-clickback-delta
168          clicked-clickback-delta)))
169  
170  (define next-untitled-name
171    (let ([n 1])
172      (λ ()
173        (begin0
174          (cond
175            [(= n 1) (string-constant untitled)]
176            [else (format (string-constant untitled-n) n)])
177          (set! n (+ n 1))))))
178  
179  (define cursor-delay
180    (let ([x 0.25])
181      (case-lambda
182        [() x]
183        [(v) (set! x v) x])))
184  
185  (define show-busy-cursor
186    (lambda (thunk [delay (cursor-delay)])
187      (local-busy-cursor #f thunk delay)))
188  
189  (define delay-action
190    (λ (delay-time open close)
191      (let ([semaphore (make-semaphore 1)]
192            [open? #f]
193            [skip-it? #f])
194        (thread 
195         (λ ()
196           (sleep delay-time)
197           (semaphore-wait semaphore)
198           (unless skip-it?
199             (set! open? #t)
200             (open))
201           (semaphore-post semaphore)))
202        (λ ()
203          (semaphore-wait semaphore)
204          (set! skip-it? #t)
205          (when open?
206            (close))
207          (semaphore-post semaphore)))))
208  
209  (define local-busy-cursor
210    (let ([watch (make-object cursor% 'watch)])
211      (case-lambda
212        [(win thunk) (local-busy-cursor win thunk (cursor-delay))]
213        [(win thunk delay)
214         (let* ([old-cursor #f]
215                [cursor-off void])
216           (dynamic-wind
217            (λ ()
218              (set! cursor-off
219                    (delay-action
220                     delay
221                     (λ ()
222                       (if win
223                           (begin (set! old-cursor (send win get-cursor))
224                                  (send win set-cursor watch))
225                           (begin-busy-cursor)))
226                     (λ ()
227                       (if win
228                           (send win set-cursor old-cursor)
229                           (end-busy-cursor))))))
230            (λ () (thunk))
231            (λ () (cursor-off))))])))
232  
233  (define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t]
234                           #:dialog-mixin [dialog-mixin values])
235    (define key-closed #f)
236    (define (unsaved-warning-mixin %)
237      (class %
238        (inherit show)
239        (define/override (on-subwindow-char receiver evt)
240          (define (is-menu-key? char)
241            (and (send evt get-meta-down)
242                 (equal? (send evt get-key-code) char)))
243          (cond
244            [(is-menu-key? #\d)
245             (set! key-closed 'continue)
246             (show #f)]
247            [(is-menu-key? #\s)
248             (set! key-closed 'save)
249             (show #f)]
250            [(is-menu-key? #\c)
251             (set! key-closed 'cancel)
252             (show #f)]
253            [else
254             (super on-subwindow-char receiver evt)]))
255        (super-new)))
256    (define mb-res 
257      (message-box/custom 
258       (string-constant warning)
259       (format (string-constant file-is-not-saved) filename)
260       (string-constant save)
261       (and cancel? (string-constant cancel))
262       action-anyway
263       parent
264       (if can-save-now?
265           '(default=1 caution)
266           '(default=2 caution))
267       2
268       #:dialog-mixin (if (equal? (system-type) 'macosx)
269                          (compose unsaved-warning-mixin dialog-mixin)
270                          dialog-mixin)))
271    (or key-closed
272        (case mb-res
273          [(1) 'save]
274          [(2) 'cancel]
275          [(3) 'continue])))
276  
277  (define (get-choice message
278                      true-choice
279                      false-choice
280                      [title (string-constant warning)]
281                      [default-result 'disallow-close]
282                      [parent #f]
283                      [style 'app]
284                      [checkbox-proc #f]
285                      [checkbox-label (string-constant dont-ask-again)]
286                      #:dialog-mixin [dialog-mixin values])
287    (let* ([check? (and checkbox-proc (checkbox-proc))]
288           [style  (if (eq? style 'app) `(default=1) `(default=1 ,style))]
289           [style  (if (eq? 'disallow-close default-result)
290                       (cons 'disallow-close style) style)]
291           [style  (if check? (cons 'checked style) style)]
292           [return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
293      (if checkbox-proc
294          (let-values ([(mb-res checked)
295                        (message+check-box/custom title message checkbox-label
296                                                  true-choice false-choice #f
297                                                  parent style default-result
298                                                  #:dialog-mixin dialog-mixin)])
299            (checkbox-proc checked)
300            (return mb-res))
301          (return (message-box/custom title message true-choice false-choice #f
302                                      parent style default-result
303                                      #:dialog-mixin dialog-mixin)))))
304  
305  ;; manual renaming
306  (define gui-utils:trim-string trim-string)
307  (define gui-utils:quote-literal-label quote-literal-label)
308  (define gui-utils:format-literal-label format-literal-label)
309  (define gui-utils:next-untitled-name next-untitled-name)
310  (define gui-utils:show-busy-cursor show-busy-cursor)
311  (define gui-utils:delay-action delay-action)
312  (define gui-utils:local-busy-cursor local-busy-cursor)
313  (define gui-utils:unsaved-warning unsaved-warning)
314  (define gui-utils:get-choice get-choice)
315  (define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
316  (define gui-utils:get-clickback-delta get-clickback-delta)
317  (define gui-utils:ok/cancel-buttons ok/cancel-buttons)
318  (define gui-utils:cancel-on-right? cancel-on-right?)
319  (define gui-utils:cursor-delay cursor-delay)
320  
321  
322  (provide/doc
323   (proc-doc
324    gui-utils:trim-string
325    (->i ([str string?]
326          [size (and/c number? positive?)])
327         ()
328         [res (size)
329              (and/c string?
330                     (λ (str)
331                       ((string-length str) . <= . size)))])
332    @{Constructs a string whose size is less
333      than @racket[size] by trimming the @racket[str]
334      and inserting an ellispses into it.})
335  
336   (proc-doc/names
337    gui-utils:quote-literal-label
338    (->* (string?)
339         (#:quote-amp? any/c)
340         (and/c string?
341                (λ (str) ((string-length str) . <= . 200))))
342    ((string)
343     ((quote-amp? #t)))
344    @{Constructs a string whose length is less than @racket[200] and,
345      if @racket[quote-amp?] is not @racket[#f], then it also quotes
346      the ampersand in the result (making the string suitable for use in
347      @racket[menu-item%] label, for example).})
348  
349   (proc-doc
350    gui-utils:format-literal-label
351    (->i ([str string?])
352         ()
353         #:rest [rest (listof any/c)]
354         [res (str)
355              (and/c string?
356                     (lambda (str)
357                       ((string-length str) . <= . 200)))])
358    @{Formats a string whose ampersand characters are
359      mk-escaped; the label is also trimmed to <= 200
360      mk-characters.})
361  
362   (proc-doc/names
363    gui-utils:cancel-on-right?
364    (-> boolean?)
365    ()
366    @{Returns @racket[#t] if cancel should be on the right-hand side (or below)
367      in a dialog and @racket[#f] otherwise.
368      
369      Just returns what @racket[system-position-ok-before-cancel?] does.
370      
371      See also @racket[gui-utils:ok/cancel-buttons].})
372   (proc-doc/names
373    gui-utils:ok/cancel-buttons
374    (->* ((is-a?/c area-container<%>)
375          ((is-a?/c button%) (is-a?/c event%) . -> . any)
376          ((is-a?/c button%) (is-a?/c event%) . -> . any))
377         (string?
378          string?
379          #:confirm-style (listof symbol?))
380         (values (is-a?/c button%)
381                 (is-a?/c button%)))
382    ((parent
383      confirm-callback
384      cancel-callback)
385     ((confirm-label (string-constant ok))
386      (cancel-label (string-constant cancel))
387      (confirm-style '(border))))
388    @{Adds an Ok and a cancel button to a panel, changing the order
389      to suit the platform. Under Mac OS and unix, the confirmation action
390      is on the right (or bottom) and under Windows, the canceling action is on
391      the right (or bottom).
392      The buttons are also sized to be the same width.
393      
394      The first result is be the OK button and the second is
395      the cancel button.
396      
397      By default, the confirmation action button has the @racket['(border)] style,
398      meaning that hitting return in the dialog will trigger the confirmation action.
399      The @racket[confirm-style] argument can override this behavior, tho.
400      See @racket[button%] for the precise list of allowed styles.
401      
402      See also @racket[gui-utils:cancel-on-right?].})
403   
404   (proc-doc/names
405    gui-utils:next-untitled-name
406    (-> string?)
407    ()
408    @{Returns a name for the next opened untitled frame. The first
409      name is ``Untitled'', the second is ``Untitled 2'',
410      the third is ``Untitled 3'', and so forth.})
411   (proc-doc/names
412    gui-utils:cursor-delay
413    (case->
414     (-> real?)
415     (real? . -> . void?))
416    (() (new-delay))
417    @{This function is @italic{not} a parameter.
418      Instead, the state is just stored in the closure.
419      
420      The first case in the case lambda
421      returns the current delay in seconds before a watch cursor is shown,
422      when either @racket[gui-utils:local-busy-cursor] or
423      @racket[gui-utils:show-busy-cursor] is called.
424      
425      The second case in the case lambda
426      Sets the delay, in seconds, before a watch cursor is shown, when
427      either @racket[gui-utils:local-busy-cursor] or
428      @racket[gui-utils:show-busy-cursor] is called.})
429   (proc-doc/names
430    gui-utils:show-busy-cursor
431    (->* ((-> any/c))
432         (integer?)
433         any/c)
434    ((thunk)
435     ((delay (gui-utils:cursor-delay))))
436    @{Evaluates @racket[(thunk)] with a watch cursor. The argument
437      @racket[delay] specifies the amount of time before the watch cursor is
438      opened. Use @racket[gui-utils:cursor-delay] to set this value
439      to all calls.
440      
441      This function returns the result of @racket[thunk].})
442   (proc-doc/names
443    gui-utils:delay-action
444    (real?
445     (-> void?)
446     (-> void?)
447     . -> .
448     (-> void?))
449    (delay-time open close)
450    @{Use this function to delay an action for some period of time. It also
451      supports canceling the action before the time period elapses. For
452      example, if you want to display a watch cursor, but you only want it
453      to appear after 2 seconds and the action may or may not take more than
454      two seconds, use this pattern:
455      
456      @racketblock[(let ([close-down
457                          (gui-utils:delay-action
458                           2
459                           (λ () .. init watch cursor ...)
460                           (λ () .. close watch cursor ...))])
461                     ;; .. do action ...
462                     (close-down))]
463      
464      Creates a thread that waits @racket[delay-time]. After @racket[delay-time]
465      has elapsed, if the result thunk has @italic{not} been called, call
466      @racket[open]. Then, when the result thunk is called, call
467      @racket[close]. The function @racket[close] will only be called if
468      @racket[open] has been called.})
469   
470   (proc-doc/names
471    gui-utils:local-busy-cursor
472    (->*
473     ((is-a?/c window<%>)
474      (-> any/c))
475     (integer?)
476     any/c)
477    ((window thunk)
478     ((delay (gui-utils:cursor-delay))))
479    @{Evaluates @racket[(thunk)] with a watch cursor in @racket[window]. If
480      @racket[window] is @racket[#f], the watch cursor is turned on globally.
481      The argument @racket[delay] specifies the amount of time before the watch
482      cursor is opened. Use @racket[gui-utils:cursor-delay]
483      to set this value for all uses of this function.
484      
485      The result of this function is the result of @racket[thunk].})
486   
487   (proc-doc/names
488    gui-utils:unsaved-warning
489    (->*
490     (string?
491      string?)
492     (boolean?
493      (or/c false/c
494            (is-a?/c frame%)
495            (is-a?/c dialog%))
496      boolean?
497      #:dialog-mixin (make-mixin-contract dialog%))
498     (symbols 'continue 'save 'cancel))
499    ((filename action)
500     ((can-save-now? #f)
501      (parent #f)
502      (cancel? #t)
503      (dialog-mixin values)))
504    
505    @{This displays a dialog that warns the user of a unsaved file.
506      
507      The string, @racket[action], indicates what action is about to
508      take place, without saving. For example, if the application
509      is about to close a file, a good action is @racket["Close Anyway"].
510      The result symbol indicates the user's choice. If
511      @racket[can-save-now?] is @racket[#f], this function does not
512      give the user the ``Save'' option and thus will not return
513      @racket['save].
514      
515      If @racket[cancel?] is @racket[#t] there is a cancel button
516      in the dialog and the result may be @racket['cancel]. If it
517      is @racket[#f], then there is no cancel button, and @racket['cancel]
518      will not be the result of the function.
519  
520      The @racket[dialog-mixin] argument is passed to @racket[message-box/custom].
521  
522      @history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
523      
524      })
525   
526   (proc-doc/names
527    gui-utils:get-choice
528    (->* (string?
529          string?
530          string?)
531         (string?
532          any/c
533          (or/c false/c (is-a?/c frame%) (is-a?/c dialog%))
534          (symbols 'app 'caution 'stop)
535          (or/c false/c (case-> (boolean? . -> . void?)
536                                (-> boolean?)))
537          string?
538          #:dialog-mixin (make-mixin-contract dialog%))
539         any/c)
540    ((message true-choice false-choice)
541     ((title (string-constant warning))
542      (default-result 'disallow-close)
543      (parent #f)
544      (style 'app)
545      (checkbox-proc #f)
546      (checkbox-label (string-constant dont-ask-again))
547      (dialog-mixin values)))
548    
549    @{Opens a dialog that presents a binary choice to the user. The user is
550      forced to choose between these two options, ie cancelling or closing the
551      dialog opens a message box asking the user to actually choose one of the
552      two options.
553      
554      The dialog will contain the string @racket[message] and two buttons,
555      labeled with the @racket[true-choice] and the @racket[false-choice].  If the
556      user clicks on @racket[true-choice] @racket[#t] is returned. If the user
557      clicks on @racket[false-choice], @racket[#f] is returned.
558      
559      The argument @racket[default-result] determines how closing the window is
560      treated. If the argument is @racket['disallow-close], closing the window
561      is not allowed. If it is anything else, that value is returned when
562      the user closes the window.
563      
564      If @racket[gui-utils:cancel-on-right?]
565      returns @racket[#t], the false choice is on the right.
566      Otherwise, the true choice is on the right.
567      
568      The @racket[style] parameter is (eventually) passed to
569      @racket[message]
570      as an icon in the dialog.
571      
572      If @racket[checkbox-proc] is given, it should be a procedure that behaves
573      like a parameter for getting/setting a boolean value.  The intention for
574      this value is that it can be used to disable the dialog.  When it is
575      given, a checkbox will appear with a @racket[checkbox-label] label
576      (defaults to the @racket[dont-ask-again] string constant), and that
577      checkbox value will be sent to the @racket[checkbox-proc] when the dialog
578      is closed.  Note that the dialog will always pop-up --- it is the
579      caller's responsibility to avoid the dialog if not needed.
580  
581      The @racket[dialog-mixin] argument is passed to @racket[message-box/custom]
582      or @racket[message+check-box/custom].
583  
584      @history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
585  
586      })
587   
588   (proc-doc/names
589    gui-utils:get-clicked-clickback-delta
590    (->* ()
591         (boolean?)
592         (is-a?/c style-delta%))
593    (()
594     ((white-on-black? #f)))
595    @{This delta is designed for use with
596      @method[text set-clickback].
597      Use it as one of the @racket[style-delta%] argument to
598      @method[text% set-clickback].
599      
600      If @racket[white-on-black?] is true, the function returns
601      a delta suitable for use on a black background.
602      
603      See also @racket[gui-utils:get-clickback-delta].})
604   
605   (proc-doc/names
606    gui-utils:get-clickback-delta
607    (->* ()
608         (boolean?)
609         (is-a?/c style-delta%))
610    (()
611     ((white-on-black? #f)))
612    @{This delta is designed for use with @method[text% set-clickback].
613      Use the result of this function as the style
614      for the region text where the clickback is set.
615      
616      If @racket[white-on-black?] is true, the function returns
617      a delta suitable for use on a black background.
618      
619      See also
620      @racket[gui-utils:get-clicked-clickback-delta].}))