From cbcf1fba9a9f76126a1b4b230e872da5cd143825 Mon Sep 17 00:00:00 2001 From: Mike MacHenry Date: Wed, 3 Dec 2003 19:33:23 +0000 Subject: [PATCH] ... original commit: 1d5edeb1d820309361c64a8df93603f7e3688008 --- collects/test-suite/private/button-snip.ss | 44 +++++++++----- .../private/fixed-width-label-snip.ss | 6 ++ collects/test-suite/private/tabbable-text.ss | 58 +++++++++++++++++++ 3 files changed, 92 insertions(+), 16 deletions(-) create mode 100644 collects/test-suite/private/tabbable-text.ss diff --git a/collects/test-suite/private/button-snip.ss b/collects/test-suite/private/button-snip.ss index ebc63cde..71c09a23 100644 --- a/collects/test-suite/private/button-snip.ss +++ b/collects/test-suite/private/button-snip.ss @@ -3,9 +3,7 @@ (require (lib "mred.ss" "mred") (lib "class.ss") - (lib "etc.ss") - (lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard") - (lib "click-forwarding-editor.ss" "mrlib")) + (lib "etc.ss")) (provide button-snip% @@ -19,6 +17,7 @@ (init-field callback) (field [got-click? false] + [inside? false] [image (car images)] [depressed (cdr images)]) @@ -29,21 +28,26 @@ (set! depressed (cdr i)) (load-file image)) + ;; Should I be calling super-on-event? (rename [super-on-event on-event]) (define/override (on-event dc x y editorx editory event) (case (send event get-event-type) [(left-down) (set! got-click? true) + (set! inside? true) (load-file depressed)] [(left-up) - (when got-click? - (load-file image) - (set! got-click? false) - (callback this event))] + (load-file image) + (when (and got-click? inside?) + (callback this event)) + (set! got-click? false) + (set! inside? false)] [(enter) + (set! inside? true) (when got-click? (load-file depressed))] [(leave) + (set! inside? false) (when got-click? (load-file image))] [else (void)])) @@ -61,16 +65,21 @@ (lambda (b e) (if (= state 1) (begin - (callback1 b e) (set-images images2) - (set! state 2)) + (set! state 2) + (callback1 b e)) (begin - (callback2 b e) (set-images images1) - (set! state 1)))))))) + (set! state 1) + (callback2 b e)))))))) ;;;;;;;;;; ;; tests + + (require + (lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard") + (lib "click-forwarding-editor.ss" "mrlib")) + (define (test) (define f (new frame% (label "test") (width 200) (height 200))) (define e (new (locked-pasteboard-mixin @@ -78,7 +87,7 @@ (define c (new editor-canvas% (editor e) (parent f))) (define b (new button-snip% (images (cons (build-path (collection-path "icons") "turn-up.gif") - (build-path (collection-path "icons") "turn-down.gif"))) + (build-path (collection-path "icons") "turn-up-click.gif"))) (callback (lambda (b e) (message-box "Test" "Horray!"))))) @@ -90,17 +99,20 @@ (define e (new (locked-pasteboard-mixin (click-forwarding-editor-mixin pasteboard%)))) (define c (new editor-canvas% (editor e) (parent f))) + (define t (new text%)) + (define es (new editor-snip% (editor t))) (define b (new toggle-button-snip% (images1 (cons (build-path (collection-path "icons") "turn-up.gif") - (build-path (collection-path "icons") "turn-up.gif"))) + (build-path (collection-path "icons") "turn-up-click.gif"))) (images2 (cons (build-path (collection-path "icons") "turn-down.gif") - (build-path (collection-path "icons") "turn-down.gif"))) + (build-path (collection-path "icons") "turn-down-click.gif"))) (callback1 (lambda (b e) - (message-box "Test" "Horray!"))) + (send* t (erase) (insert "Up")))) (callback2 (lambda (b e) - (message-box "Test" "Horray, Horray!"))))) + (send* t (erase) (insert "Down")))))) + (send e insert es 50 0) (send e insert b) (send f show #t)) ) \ No newline at end of file diff --git a/collects/test-suite/private/fixed-width-label-snip.ss b/collects/test-suite/private/fixed-width-label-snip.ss index d5bc154d..bc21b4e8 100644 --- a/collects/test-suite/private/fixed-width-label-snip.ss +++ b/collects/test-suite/private/fixed-width-label-snip.ss @@ -18,6 +18,12 @@ (top-margin 5) (bottom-margin 5)) + (unless (member label labels) + (error 'fixed-width-label-snip + "Instantiation of label-snip expected one of ~s. Given ~s" + labels + label)) + (define (get-string-size dc string) (let-values ([(width height baseline vspace) (send dc get-text-extent string)]) diff --git a/collects/test-suite/private/tabbable-text.ss b/collects/test-suite/private/tabbable-text.ss new file mode 100644 index 00000000..42a35fcc --- /dev/null +++ b/collects/test-suite/private/tabbable-text.ss @@ -0,0 +1,58 @@ +(module tabbable-text mzscheme + + (require + (lib "class.ss") + (lib "list.ss") + (lib "etc.ss") + (lib "framework.ss" "framework") + (lib "mred.ss" "mred") + (lib "contract.ss")) + + (define tabbable-text<%> (interface () set-caret-owner)) + + (provide/contract + (tabbable-text<%> interface?) + (tabbable-text-mixin mixin-contract) + (set-tabbing (() (listof (is-a?/c tabbable-text<%>)) . ->* . (void?)))) + + (define tabbable-text-mixin + (mixin (editor:keymap<%>) (tabbable-text<%>) + + (init-field + [ahead #f] + [back #f]) + + ;; get-keymaps (-> (listof keymap%)) + ;; the list of keymaps associated with this text + (rename [super-get-keymaps get-keymaps]) + (define/override (get-keymaps) + (let ([keymap (make-object keymap%)]) + (when ahead + (send keymap add-function "tab-ahead" + (lambda (ignored event) + (ahead))) + (send keymap map-function ":tab" "tab-ahead")) + (when back + (send keymap add-function "tab-back" + (lambda (ignored event) + (back))) + (send keymap map-function "s:tab" "tab-back")) + (cons keymap (super-get-keymaps)))) + + (define/public (set-ahead t) (set! ahead t)) + (define/public (set-back t) (set! back t)) + + (super-new))) + + + ;; sets the tabbing of all of the texts in the order of the list + (define (set-tabbing . l) + (cond + [(or (empty? l) (empty? (rest l))) (void)] + [else + (send (first l) set-ahead + (lambda () (send (second l) set-caret-owner false 'global))) + (send (second l) set-back + (lambda () (send (first l) set-caret-owner false 'global))) + (apply set-tabbing (rest l))])) + ) \ No newline at end of file