From 919883a7fb868ccb26c433b64a2dd81fff91968a Mon Sep 17 00:00:00 2001
From: Mike MacHenry <dskippy@ccs.neu.edu>
Date: Fri, 27 Aug 2004 18:17:30 +0000
Subject: [PATCH] commited tests

original commit: e3c010a3e3d7aa218b776eb623bb80b32dbb2301
---
 .../private/tests/test-case-box.ss            | 175 ++++++++++++
 .../tests/test-show-feature-for-test-case.ss  |  72 +++++
 .../private/tests/test-show-feature.ss        | 261 ++++++++++++++++++
 3 files changed, 508 insertions(+)
 create mode 100644 collects/embedded-gui/private/tests/test-case-box.ss
 create mode 100644 collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss
 create mode 100644 collects/embedded-gui/private/tests/test-show-feature.ss

diff --git a/collects/embedded-gui/private/tests/test-case-box.ss b/collects/embedded-gui/private/tests/test-case-box.ss
new file mode 100644
index 00000000..294b76a1
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-case-box.ss
@@ -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)
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss b/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss
new file mode 100644
index 00000000..e2f8334d
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-show-feature-for-test-case.ss
@@ -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)
\ No newline at end of file
diff --git a/collects/embedded-gui/private/tests/test-show-feature.ss b/collects/embedded-gui/private/tests/test-show-feature.ss
new file mode 100644
index 00000000..3d84bebc
--- /dev/null
+++ b/collects/embedded-gui/private/tests/test-show-feature.ss
@@ -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))))))
\ No newline at end of file