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

commited tests

Browse Source 
original commit: e3c010a3e3d7aa218b776eb623bb80b32dbb2301
This commit is contained in:
Mike MacHenry 2004-08-27 18:17:30 +00:00
parent 1031a8ac92
commit 919883a7fb
3 changed files with 508 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
collects/embedded-gui/private/tests/test-case-box.ss Normal file
View File

@ -0,0 +1,175 @@
(require
(lib "class.ss")
(lib "list.ss")
(lib "mred.ss" "mred")
(lib "unitsig.ss")
(lib "tool.ss" "drscheme")
(lib "etc.ss")
(lib "match.ss")
(lib "framework.ss" "framework")
(lib "readerr.ss" "syntax")
(lib "string-constant.ss" "string-constants")
(lib "embedded-gui.ss" "embedded-gui")
(lib "string-constant.ss" "string-constants"))
(define test-case:program-editor% text%)
(define test-case-box%
(class editor-snip%
(inherit get-admin)
(init-field
[enabled? true]
[actual-show? true]
[collapsed? false]
[to-test (new test-case:program-editor%)]
[expected (new test-case:program-editor%)])
(field
[actual (new actual-text%)]
[result (new result-snip%
(status (if enabled?
'unknown
'disabled)))])
(define (show-actual show?)
(set! actual-show? show?)
(send show-actual-button set-state
(boolean->show-actual-btn-state show?))
(send actual-pane show show?))
(define (collapse bool)
(set! collapsed? bool)
(send collapse-button set-state
(boolean->collapse-btn-state bool))
(send pb lock-alignment true)
(send left show (not bool))
(send right show (not bool))
(send pb lock-alignment false))
(define (boolean->collapse-btn-state bool)
(if bool 'on 'off))
(define (boolean->show-actual-btn-state bool)
(if bool 'off 'on))
(field
[pb (new aligned-pasteboard%)]
[main (new horizontal-alignment% (parent pb))]
[left (new vertical-alignment%
(parent main)
(show? (not collapsed?)))]
[right (new vertical-alignment%
(parent main)
(show? (not collapsed?)))]
[button-pane (new vertical-alignment% (parent main))]
[to-test-pane (new vertical-alignment% (parent left))]
[expected-pane (new vertical-alignment% (parent right))]
[actual-pane (new vertical-alignment%
(parent right)
(show? actual-show?))]
[collapse-button
(new turn-button-snip%
(state (boolean->collapse-btn-state collapsed?))
(turn-off
(lambda (b e) (collapse true)))
(turn-on
(lambda (b e) (collapse false))))]
[show-actual-button
(new turn-button-snip%
(state (boolean->show-actual-btn-state actual-show?))
(turn-off
(lambda (b e) (show-actual false)))
(turn-on
(lambda (b e) (show-actual true))))])
(super-new (editor pb))
(define (labeled-field alignment label text)
;; I string-append here to give space after the label
;; They look a lot better without something right after them.
(new snip-wrapper%
(snip (make-object string-snip% (string-append label " ")))
(parent alignment))
(new snip-wrapper%
(snip (new stretchable-editor-snip%
(editor text)
(stretchable-height false)))
(parent alignment)))
(labeled-field to-test-pane (string-constant test-case-to-test) to-test)
(labeled-field expected-pane (string-constant test-case-expected) expected)
(new snip-wrapper%
(snip (make-object string-snip% (string-constant test-case-actual)))
(parent actual-pane))
(new snip-wrapper%
(snip (new (grey-editor-snip-mixin stretchable-editor-snip%)
(editor actual)
(stretchable-height false)))
(parent actual-pane))
(new snip-wrapper%
(snip result)
(parent button-pane))
;; NOTE: When you add the collapse feature, be sure that
;; error-reporting on collapsed test-cases highlight the
;; test-case. (PR6955)
(new snip-wrapper%
(snip collapse-button)
(parent button-pane))
(new snip-wrapper%
(snip show-actual-button)
(parent button-pane))
))
#;((-> void?) (-> void?) (symbols 'up 'down) . -> . snip%)
;; a snip which acts as a toggle button for rolling a window up and down
(define turn-button-snip%
(class toggle-button-snip%
(super-new
(images-off (cons (icon "turn-down.gif") (icon "turn-down-click.gif")))
(images-on (cons (icon "turn-up.gif") (icon "turn-up-click.gif"))))))
;; a snip which will display a pass/fail result
(define result-snip%
(class image-snip%
(inherit load-file)
(init-field [status 'unknown])
;; ((symbols 'pass 'fail 'unknown 'disabled) . -> . void?)
;; updates the image with the icon representing one of three results
(define/public (update value)
(load-file
(test-icon
(case value
[(pass) "small-check-mark.jpeg"]
[(fail) "small-cross.jpeg"]
[(unknown) "small-empty.gif"]
[(disabled) "small-no.gif"]))))
(super-new)
(update status)))
(define (icon str)
(build-path (collection-path "icons") str))
(define (test-icon str)
(build-path (collection-path "test-suite") "private" "icons" str))
;; a locked text hightlighted to show that it is inactive
(define actual-text%
(class (grey-editor-mixin
(text:hide-caret/selection-mixin scheme:text%))
(inherit hide-caret lock)
(super-new)
(hide-caret true)
(lock true)))
(define f (new frame% (label "f") (width 400) (height 400)))
(define e (new text%))
(define c (new editor-canvas% (parent f) (editor e)))
(define t (new test-case-box%))
(send f show #t)
(send e insert t)

72
collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss Normal file
View File

@ -0,0 +1,72 @@
(require
(lib "class.ss")
(lib "mred.ss" "mred")
"../aligned-pasteboard.ss"
"../verthoriz-alignment.ss"
"../snip-wrapper.ss"
"../stretchable-editor-snip.ss")
(define actual-show? #f)
(define collapsed? #t)
(define actual (new text%))
(define to-test (new text%))
(define expected (new text%))
(define pb (new aligned-pasteboard%))
(define main (new horizontal-alignment% (parent pb)))
(define left (new vertical-alignment%
(parent main)
(show? (not collapsed?))))
(define right (new vertical-alignment%
(parent main)
(show? (not collapsed?))))
(define button-pane (new vertical-alignment% (parent main)))
(define to-test-pane (new vertical-alignment% (parent left)))
(define expected-pane (new vertical-alignment% (parent right)))
(define actual-pane (new vertical-alignment%
(parent right)
(show? actual-show?)))
(define f (new frame% (label "f") (width 400) (height 500)))
(send f show #t)
(define e (new text%))
(define c (new editor-canvas% (editor e) (parent f)))
(define es (new editor-snip% (editor pb)))
(define (show-actual show?)
(set! actual-show? show?)
(send actual-pane show actual-show?))
(define (collapse bool)
(set! collapsed? bool)
(send left show (not collapsed?))
(send right show (not collapsed?)))
(send e insert es)
(define (labeled-field alignment label text)
;; I string-append here to give space after the label
;; They look a lot better without something right after them.
(new snip-wrapper%
(snip (make-object string-snip% (string-append label " ")))
(parent alignment))
(new snip-wrapper%
(snip (new stretchable-editor-snip%
(editor text)
(stretchable-height #f)))
(parent alignment)))
(send pb lock-alignment #t)
(labeled-field to-test-pane "Test" to-test)
(labeled-field expected-pane "Expected" expected)
(new snip-wrapper%
(snip (make-object string-snip% "Actual"))
(parent actual-pane))
(new snip-wrapper%
(snip (new stretchable-editor-snip%
(editor actual)
(stretchable-height #f)))
(parent actual-pane))
(send pb lock-alignment #f)
;(collapse #t)
;(collapse #f)

261
collects/embedded-gui/private/tests/test-show-feature.ss Normal file
View File

@ -0,0 +1,261 @@
#| This tests to make sure show works. It's not a correct test because
it's been abandoned and was reduced to wont-shrink.ss This is still
a good file for sandboxing show stuff though.
|#
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(prefix a: "../alignment.ss")
"../snip-lib.ss"
"../interface.ss"
"../alignment-helpers.ss"
(lib "click-forwarding-editor.ss" "mrlib")
"../on-show-pasteboard.ss"
"../really-resized-pasteboard.ss"
"../interface.ss"
"../snip-lib.ss"
"../locked-pasteboard.ss"
"../verthoriz-alignment.ss"
"../suppress-modify-editor.ss")
(require (lib "print-debug.ss" "mike-lib"))
(define aligned-pasteboard%
(class (click-forwarding-editor-mixin
(on-show-pasteboard-mixin
(suppress-modify-editor-mixin
(locked-pasteboard-mixin
(really-resized-pasteboard-mixin pasteboard%)))))
(inherit begin-edit-sequence end-edit-sequence
get-max-view-size refresh-delayed?)
(init align)
(field
[alignment (new (case align
[(horizontal) horizontal-alignment%]
[(vertical) vertical-alignment%]))]
[lock-alignment? false]
[needs-alignment? false])
(define/public (get-alignment) alignment)
#|
snip : snip% object
before : snip% object or #f
x : real number
y : real number
|#
(rename [super-after-insert after-insert])
(define/override (after-insert snip before x y)
(super-after-insert snip before x y)
(realign))
#|
snip : snip% object
|#
(rename [super-after-delete after-delete])
(define/override (after-delete snip)
(super-after-delete snip)
(realign))
#|
snip : snip% object
|#
(rename [super-really-resized really-resized])
(define/override (really-resized snip)
(super-really-resized snip)
(realign))
(rename [super-on-show on-show])
(define/override (on-show)
(realign)
(super-on-show))
(define/public (lock-alignment lock?)
(set! lock-alignment? lock?)
(when (and needs-alignment? (not lock-alignment?))
(realign))
(if lock?
(begin-edit-sequence)
(end-edit-sequence)))
(define/public (realign)
(if lock-alignment?
(set! needs-alignment? true)
(fluid-let ([lock-alignment? true])
(send alignment set-min-sizes)
(let ([width (send alignment get-min-width)]
[height (send alignment get-min-height)])
(unless (or (zero? width) (zero? height))
(send alignment align 0 0 width height)
(set! needs-alignment? false))))))
(super-new)
(send alignment set-pasteboard this)))
(define (vert/horiz-alignment type)
(class* object% (alignment<%>)
(init-field
[parent false]
[show? true])
(field
[pasteboard false]
[children empty]
[min-width 0]
[min-height 0])
;; STATUS: This function (through lock-alignment false) invokes a call
;; to realign of the pasteboard even when this alignement has show? = false
;; so the call is not needed.
(define/public (add child)
(set! children (append children (list child)))
(send pasteboard lock-alignment true)
(cond
[(is-a? child snip%)
(when (get-show?)
(send pasteboard insert child false))]
[(is-a? child alignment<%>)
(send child set-pasteboard pasteboard)])
(send pasteboard lock-alignment false))
(define/public (get-min-width)
(if (get-show?) min-width 0))
(define/public (get-min-height)
(if (get-show?) min-height 0))
(define/public (set-pasteboard pb) (set! pasteboard pb))
(define/public (stretchable-width?) true)
(define/public (stretchable-height?) true)
#;(boolean? . -> . void?)
;; Shows or hides the alignment
(define/public (show bool)
(set! show? bool)
(when (parent-show?)
(send pasteboard lock-alignment true)
(show/hide-snips show?)
(send pasteboard lock-alignment false)))
#;(boolean? . -> . void?)
;; Inserts or deletes all the snips in the tree.
(define/public (show/hide-snips bool)
(when (boolean=? show? bool)
(for-each (show/hide-child bool) children)))
(define ((show/hide-child show?) child)
(if (is-a? child alignment<%>)
(send child show/hide-snips show?)
(if show?
(send pasteboard insert child)
(send pasteboard release-snip child))))
(define/public (get-show?)
(and show? (parent-show?)))
(define (parent-show?)
(if (and parent (is-a? parent alignment<%>))
(send parent get-show?)
true))
(define/public (align x-offset y-offset width height)
(define move/resize
(match-lambda*
[(child ($ a:rect
($ a:dim x w stretchable-width?)
($ a:dim y h stretchable-height?)))
(let ([global-x (+ x x-offset)]
[global-y (+ y y-offset)])
(cond
[(is-a? child snip%)
(send pasteboard move-to child global-x global-y)
(when (or stretchable-width? stretchable-height?)
(send child stretch w h))]
[(is-a? child alignment<%>)
(send child align global-x global-y w h)]))]))
(when (and (get-show?) (not (empty? children)))
(for-each move/resize
children
(a:align type width height
(map build-rect children)))))
(define/public (set-min-sizes)
(when show?
(for-each
(lambda (child)
(when (is-a? child alignment<%>)
(send child set-min-sizes)))
children)
(let-values ([(x-accum y-accum)
(if (symbol=? type 'vertical)
(values vacuous-max +)
(values + vacuous-max))])
(set! min-width
(apply x-accum
(map child-width
children)))
(set! min-height
(apply y-accum
(map child-height
children))))))
(super-new)
;; NOTE: Try to figure out how it's getting a nonalignment<%> parent
(when (and parent (is-a? parent alignment<%>))
(send parent add this))))
(define vertical-alignment% (vert/horiz-alignment 'vertical))
(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
;; build-rect ((is-a?/c snip%) . -> . rect?)
;; makes a new default rect out of a snip
(define (build-rect item)
(cond
[(is-a? item snip%)
(a:make-rect
(a:make-dim 0 (snip-min-width item) (stretchable-width? item))
(a:make-dim 0 (snip-min-height item) (stretchable-height? item)))]
[(is-a? item alignment<%>)
(a:make-rect
(a:make-dim 0 (send item get-min-width) (send item stretchable-width?))
(a:make-dim 0 (send item get-min-height) (send item stretchable-height?)))]))
;;;;;;;;;;
;; main
(define f (new frame% (label "f") (width 400) (height 400)))
(define e (new text%))
(define c (new editor-canvas% (parent f) (editor e)))
(define ap (new aligned-pasteboard% (align 'horizontal)))
(define es (new editor-snip% (editor ap)))
(define a1 (send ap get-alignment))
(define a2 (new vertical-alignment% (parent a1)))
(define a3 (new vertical-alignment% (parent a1)))
(define a4 (new vertical-alignment% (parent a3)))
(define a5 (new vertical-alignment% (parent a3) (show? #f)))
(send a2 add (make-object string-snip% "a2"))
(send a4 add (make-object string-snip% "a4"))
(send a5 add (make-object string-snip% "a5"))
;; this next line blows up but should not
#;(send a5 show #t)
(send f show #t)
(send e insert es)
(let ([a (send a1 get-min-height)])
(send a5 show #t)
(let ([b (send a1 get-min-height)])
(send a5 show #f)
(let ([c (send a1 get-min-height)])
(values (equal? a c)
(equal? a (/ b 2))))))