suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rackety

Browse Source
This commit is contained in:
Robby Findler 2017-01-15 07:59:09 -06:00
parent 757a3c2463
commit 97b23af4b1
1 changed files with 61 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gui-lib/framework/private/group.rkt
View File

@ -279,27 +279,28 @@
(exit:exit)))))
(define (choose-a-frame parent)
(letrec-values ([(sorted-frames)
(define sorted-frames
(sort
(send (get-the-frame-group) get-frames)
(λ (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% ()
(λ (x y) (string-ci<=? (send x get-label) (send y get-label)))))
(define d
(make-object dialog% (string-constant bring-frame-to-front) parent 400 600))
(define lb
(new list-box%
(label #f)
(choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
(callback (λ (x y) (listbox-callback y)))
(parent d))]
[(t) (instantiate text:hide-caret/selection% ())]
[(ec) (instantiate canvas:basic% ()
(parent d)))
(define t (new text:hide-caret/selection%))
(define ec (new canvas:basic%
(parent d)
(stretchable-height #f))]
[(bp) (instantiate horizontal-panel% ()
(stretchable-height #f)))
(define bp (new horizontal-panel%
(parent d)
(stretchable-height #f)
(alignment '(right center)))]
[(cancelled?) #t]
[(listbox-callback)
(λ (evt)
(alignment '(right center))))
(define cancelled? #t)
(define (listbox-callback evt)
(case (send evt get-event-type)
[(list-box)
@ -318,15 +319,15 @@
(send t end-edit-sequence))]
[(list-box-dclick)
(set! cancelled? #f)
(send d show #f)]))]
[(ok cancel)
(send d show #f)]))
(define-values (ok cancel)
(gui-utils:ok/cancel-buttons
bp
(λ (x y)
(set! cancelled? #f)
(send d show #f))
(λ (x y)
(send d show #f)))])
(send d show #f))))
(send ec set-line-count 3)
(send ec set-editor t)
(send t auto-wrap #t)
@ -339,7 +340,7 @@
(unless cancelled?
(let ([sels (send lb get-selections)])
(unless (null? sels)
(send (list-ref sorted-frames (car sels)) show #t))))))
(send (list-ref sorted-frames (car sels)) show #t)))))
(define (internal-get-the-frame-group)