587 lines
23 KiB
Scheme
587 lines
23 KiB
Scheme
#| Note: Test cases have a lot of state like the to-test, predicate, etc. I need to find a way
|
|
to not have to maintain this list of state in many places. It's not as simple as a global
|
|
list, however, because they need to be instantiation variables, etc.
|
|
|#
|
|
(module test-case-box mzscheme
|
|
|
|
(provide test-case-box^ test-case-box@)
|
|
|
|
(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")
|
|
"make-snipclass.ss"
|
|
"convert-to-string.ss"
|
|
"text-syntax-object.ss"
|
|
"print-to-text.ss"
|
|
"test-case.ss"
|
|
(only (lib "teachprims.ss" "lang" "private") beginner-equal?))
|
|
|
|
(define-signature test-case-box^ (test-case-box% phase1 phase2))
|
|
(define test-case-box@
|
|
(unit/sig test-case-box^
|
|
(import drscheme:tool^ text->syntax-object^ print-to-text^)
|
|
|
|
(define test-case:program-editor% false)
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2)
|
|
(set! test-case:program-editor%
|
|
(init-text-mixin
|
|
(tabbable-text-mixin
|
|
((drscheme:unit:get-program-editor-mixin)
|
|
scheme:text%)))))
|
|
|
|
;; The test case box that is inserted into the drscheme frame
|
|
(define test-case-box%
|
|
(class* (on-show-editor-snip-mixin
|
|
(convert-to-string-mixin
|
|
(decorated-editor-snip-mixin editor-snip%))) (readable-snip<%>)
|
|
(inherit get-admin convert-to-string)
|
|
|
|
;; A text that will uncollapse the test case when it is highlighted for an error
|
|
(define error-alert-text%
|
|
(class test-case:program-editor%
|
|
(define/override highlight-range
|
|
(opt-lambda (start end color (bitmap false) (caret-space false) (priority 'low))
|
|
(when collapsed? (collapse false))
|
|
(super highlight-range start end color bitmap caret-space priority)))
|
|
(super-new)))
|
|
|
|
(init-field
|
|
[enabled? true]
|
|
[actual-show? false]
|
|
[collapsed? false]
|
|
[show-right-pane? false]
|
|
[error-box? false]
|
|
[to-test (new error-alert-text%)]
|
|
[expected (new error-alert-text%)]
|
|
[predicate (new error-alert-text% (text ""))]
|
|
[should-raise (new error-alert-text% (text ""))]
|
|
[error-message (new error-alert-text%)])
|
|
|
|
#;(any? (union integer? false?) (union integer? false?) (union integer? false?) . -> . any?)
|
|
;; Called by the execution to get a syntax object that represents this box.
|
|
(define/public read-special
|
|
(opt-lambda (source (line false) (column false) (position false))
|
|
#;((is-a?/c text%) . -> . syntax-object?)
|
|
;; Creates a single syntax object out of the text or raises read-error
|
|
(define (text->syntax-object text default-content)
|
|
(match (text->syntax-objects text default-content)
|
|
[() (raise-read-error (string-constant test-case-empty-error)
|
|
source line false position 1)]
|
|
[(stx) stx]
|
|
[(stx next rest-stx ...)
|
|
(raise-read-error (string-constant test-case-too-many-expressions-error)
|
|
text
|
|
(syntax-line next)
|
|
(syntax-column next)
|
|
(syntax-position next)
|
|
(syntax-span next))]))
|
|
(syntax-property
|
|
(if enabled?
|
|
(with-syntax ([to-test-stx (syntax-property (text->syntax-object to-test #f)
|
|
'stepper-test-suite-hint
|
|
true)]
|
|
[update-stx (lambda (x) (update x))] ; eta public method
|
|
[set-actuals-stx set-actuals]
|
|
[w printf])
|
|
(if error-box?
|
|
(with-syntax ([exn-pred-stx (text->syntax-object should-raise #'exn:fail?)]
|
|
[exn-handler-stx
|
|
(if (empty-text? error-message)
|
|
#'(lambda (v) true)
|
|
#`(lambda (v)
|
|
(equal? (exn-message v)
|
|
#,(text->syntax-object
|
|
error-message
|
|
#f))))])
|
|
(syntax/loc (datum->syntax-object
|
|
false 'ignored (list source line column position 1))
|
|
(test-error-case to-test-stx
|
|
exn-pred-stx
|
|
exn-handler-stx
|
|
update-stx
|
|
set-actuals-stx)))
|
|
(with-syntax ([exp-stx (text->syntax-object expected #f)]
|
|
[pred-stx (text->syntax-object predicate beginner-equal?)])
|
|
(syntax/loc (datum->syntax-object
|
|
false 'ignored (list source line column position 1))
|
|
(test-case pred-stx
|
|
to-test-stx
|
|
exp-stx
|
|
update-stx
|
|
set-actuals-stx)))))
|
|
(syntax-property #'(define-values () (values))
|
|
'stepper-skip-completely
|
|
true))
|
|
'test-case-box #t)))
|
|
|
|
#;(boolean? . -> . void?)
|
|
;; sets the test case to the proper result bassed on if it was correct
|
|
(define/public (update pass?)
|
|
(send result update (if pass? 'pass 'fail)))
|
|
|
|
#;(-> void?)
|
|
;; resets the state of the test case
|
|
(define/public (reset)
|
|
(send pb lock-alignment true)
|
|
(send* actual
|
|
(lock false)
|
|
(erase)
|
|
(lock true))
|
|
(when enabled?
|
|
(send result update 'unknown))
|
|
(send pb lock-alignment false))
|
|
|
|
#;(boolean? . -> . void?)
|
|
;; enables or disables the test case
|
|
(define/public (enable enable?)
|
|
(unless (boolean=? enabled? enable?)
|
|
(if enable?
|
|
(begin (set! enabled? true)
|
|
(send result update 'unknown))
|
|
(begin (set! enabled? false)
|
|
(reset)
|
|
(send result update 'disabled)))))
|
|
|
|
#;(-> void)
|
|
;; tells the test-box to take the caret
|
|
(define/public (take-caret)
|
|
(send pb set-caret-owner
|
|
(send (send to-test get-admin) get-snip)
|
|
'display))
|
|
|
|
#;(-> string)
|
|
;; The textual representation of this test-case
|
|
;; STATUS: Begginner language doesn't have with-handlers
|
|
;; STATUS: Pretty printing not here yet.
|
|
(define (get-string)
|
|
(if error-box?
|
|
"Not yet implemented. What to do in beginner?"
|
|
(format "(~a ~a ~a)"
|
|
(send predicate get-text)
|
|
(send to-test get-text)
|
|
(send expected get-text))))
|
|
|
|
#;((is-a?/c expand-program%) (listof any?) . -> . void?)
|
|
;; set the text in the actual field to the value given
|
|
;; STATUS: Ensure the edit-sequence is needed.
|
|
(define (set-actuals vals)
|
|
(send (send (get-admin) get-editor) begin-edit-sequence)
|
|
(send actual lock false)
|
|
(print-to-text actual vals)
|
|
(send actual lock true)
|
|
(send (send (get-admin) get-editor) end-edit-sequence))
|
|
|
|
;;;;;;;;;;
|
|
;; Saving and Copying
|
|
|
|
#;(-> (is-a?/c test-case-box%))
|
|
;; Called by drscheme to copy and paste this test-case
|
|
(define/override (copy)
|
|
(let ([new-to-test (new error-alert-text%)]
|
|
[new-expected (new error-alert-text%)]
|
|
[new-predicate (new error-alert-text%)]
|
|
[new-should-raise (new error-alert-text%)]
|
|
[new-error-message (new error-alert-text%)])
|
|
(send to-test copy-self-to new-to-test)
|
|
(send expected copy-self-to new-expected)
|
|
(send predicate copy-self-to new-predicate)
|
|
(send should-raise copy-self-to new-should-raise)
|
|
(send error-message copy-self-to new-error-message)
|
|
(new test-case-box%
|
|
(enabled? enabled?)
|
|
(actual-show? actual-show?)
|
|
(collapsed? collapsed?)
|
|
(show-right-pane? show-right-pane?)
|
|
(error-box? error-box?)
|
|
(to-test new-to-test)
|
|
(expected new-expected)
|
|
(predicate predicate)
|
|
(should-raise should-raise)
|
|
(error-message error-message))))
|
|
|
|
#;((is-a?/c editor-stream-out%) . -> . void?)
|
|
;; Writes this test case box to the given file.
|
|
(define/override (write f)
|
|
(send to-test write-to-file f)
|
|
(send expected write-to-file f)
|
|
(send predicate write-to-file f)
|
|
(send should-raise write-to-file f)
|
|
(send error-message write-to-file f)
|
|
(send f put (if enabled? 1 0))
|
|
(send f put (if collapsed? 1 0))
|
|
(send f put (if error-box? 1 0)))
|
|
|
|
|
|
#;((is-a?/c editor-stream-in%) . -> . void?)
|
|
;; Reads the state of the box in from the given stream
|
|
(define/public (read-from-file f)
|
|
(let ([enabled?-box (box 0)]
|
|
[collapsed?-box (box 0)]
|
|
[error-box?-box (box 0)])
|
|
(let ([vers (send tcb-sc reading-version f)])
|
|
(case vers
|
|
[(1)
|
|
;; Discard comment:
|
|
(send (new text%) read-from-file f)
|
|
(send* to-test (erase) (read-from-file f))
|
|
(send* expected (erase) (read-from-file f))
|
|
;; Nothing else is in the stream in version 1,
|
|
;; so leave the defaults
|
|
]
|
|
[(2)
|
|
(send* to-test (erase) (read-from-file f))
|
|
(send* expected (erase) (read-from-file f))
|
|
(send* predicate (erase) (read-from-file f))
|
|
(send* should-raise (erase) (read-from-file f))
|
|
(send* error-message (erase) (read-from-file f))
|
|
(send f get enabled?-box)
|
|
(send f get collapsed?-box)
|
|
(send f get error-box?-box)
|
|
(enable (= (unbox enabled?-box) 1))
|
|
;; Presently this is poking a bug in the embedded-gui.
|
|
;; I'll leaving it commented til I reduce the bug.
|
|
#;(collapse (= (unbox collapsed?-box) 1))
|
|
(toggle-error-box (= (unbox error-box?-box) 1))]))))
|
|
|
|
;;;;;;;;;;
|
|
;; Layout
|
|
|
|
#;(-> (is-a?/c bitmap%))
|
|
;; The bitmap to use for the top corner of the box.
|
|
(define/override (get-corner-bitmap)
|
|
(if error-box?
|
|
(make-object bitmap% (icon "scheme-box.jpg"))
|
|
(make-object bitmap% (icon "scheme-box.jpg"))))
|
|
|
|
#;(-> (symbols 'top-right 'top-left 'bottom-left 'bottom-right))
|
|
;; The location of the corner bitmap
|
|
(define/override (get-position) 'top-right)
|
|
|
|
#;(-> (union string? (is-a?/c color%)))
|
|
;; The color of the border of this box
|
|
(define/override (get-color) (if error-box? "red" "purple"))
|
|
|
|
#;(-> (is-a?/c popup-menu%))
|
|
;; The popup menu used for the top corner of this box
|
|
(define/override (get-menu)
|
|
(let ([the-menu (new popup-menu% (title (string-constant test-case-menu-title)))])
|
|
(define (make-toggle label f init)
|
|
(letrec ([item (new checkable-menu-item%
|
|
(parent the-menu)
|
|
(label label)
|
|
(checked init)
|
|
(callback (lambda (m e)
|
|
(f (send item is-checked?)))))])
|
|
item))
|
|
(new menu-item%
|
|
(label (if error-box?
|
|
(string-constant test-case-switch-to-nonerror-box)
|
|
(string-constant test-case-switch-to-error-box)))
|
|
(parent the-menu)
|
|
(callback (lambda (m e)
|
|
(toggle-error-box (not error-box?)))))
|
|
(make-toggle
|
|
(string-constant test-case-collapse)
|
|
collapse collapsed?)
|
|
(make-toggle
|
|
(string-constant test-case-show-actual)
|
|
show-actual actual-show?)
|
|
(make-toggle
|
|
(string-constant test-case-enable)
|
|
(lambda (b) (enable b)) enabled?) ; eta public method
|
|
(make-toggle
|
|
(if error-box?
|
|
(string-constant test-case-show-error-message)
|
|
(string-constant test-case-show-predicate))
|
|
show-right-pane show-right-pane?)
|
|
(new menu-item%
|
|
(label (string-constant test-case-convert-to-text))
|
|
(parent the-menu)
|
|
(callback
|
|
(lambda (m e)
|
|
(convert-to-string (get-string)))))
|
|
the-menu))
|
|
|
|
#;(-> void)
|
|
;; Hide and show the boxes that differ between error and now and
|
|
;; poke the snip-parent to display the new boarder color
|
|
(define (toggle-error-box bool)
|
|
(set! error-box? bool)
|
|
(send pb lock-alignment true)
|
|
(send should-be-pane show (not error-box?))
|
|
(send should-raise-pane show error-box?)
|
|
(send predicate-pane show (not error-box?))
|
|
(send error-message-pane show error-box?)
|
|
(send pb lock-alignment false)
|
|
(if error-box?
|
|
(set-tabbing to-test should-raise)
|
|
(set-tabbing to-test expected))
|
|
(>>= (snip-parent this)
|
|
(lambda (admin)
|
|
(send admin resized this true))))
|
|
|
|
#;(boolean? . -> . void)
|
|
;; Shows or hides the actual box
|
|
(define (show-actual show?)
|
|
(set! actual-show? show?)
|
|
(send pb lock-alignment true)
|
|
(send show-actual-button set-state
|
|
(boolean->show-actual-btn-state show?))
|
|
(send to-test-pane stretchable-height show?)
|
|
(send actual-pane show show?)
|
|
(send pb lock-alignment false))
|
|
|
|
#;(boolean? . -> . void)
|
|
;; Toggles the test-case between a collapsed minimal state and one with entry boxes.
|
|
(define (collapse bool)
|
|
(set! collapsed? bool)
|
|
(send collapse-button set-state
|
|
(boolean->collapse-btn-state bool))
|
|
(send body show (not bool)))
|
|
|
|
#;(booean? . -> . void)
|
|
;; Shows or hides the predicate box
|
|
(define (show-right-pane show?)
|
|
(set! show-right-pane? show?)
|
|
(send right-pane show show-right-pane?))
|
|
|
|
;;;;;;;;;;
|
|
;; Box layout
|
|
|
|
(field
|
|
[pb (new aligned-pasteboard%)]
|
|
[main (new horizontal-alignment% (parent pb))])
|
|
|
|
;;;;;;;;;;
|
|
;; The button bar w/ result check mark box
|
|
|
|
(field
|
|
[button-pane (new vertical-alignment% (parent main))]
|
|
[result (new result-snip% (status (if enabled? 'unknown 'disabled)))])
|
|
(snip-wrap button-pane result)
|
|
(field
|
|
[collapse-button
|
|
(new turn-button%
|
|
(parent button-pane)
|
|
(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%
|
|
(parent button-pane)
|
|
(state (boolean->show-actual-btn-state actual-show?))
|
|
(turn-off (lambda (b e) (show-actual false)))
|
|
(turn-on (lambda (b e) (show-actual true))))])
|
|
|
|
;;;;;;;;;;
|
|
;; The text boxes
|
|
|
|
(field
|
|
[body (new horizontal-alignment% (parent main) (show? (not collapsed?)))]
|
|
[to-test-pane
|
|
(new labeled-text-field%
|
|
(parent body)
|
|
(label (string-constant test-case-to-test))
|
|
(text to-test))]
|
|
|
|
[result-pane (new vertical-alignment% (parent body))]
|
|
[should-be-pane
|
|
(new labeled-text-field%
|
|
(parent result-pane)
|
|
(show? (not error-box?))
|
|
(label (string-constant test-case-expected))
|
|
(text expected))]
|
|
[should-raise-pane
|
|
(new labeled-text-field%
|
|
(parent result-pane)
|
|
(show? error-box?)
|
|
(label (string-constant test-case-should-raise))
|
|
(text should-raise))]
|
|
[actual (new actual-text%)]
|
|
[actual-pane
|
|
(new labeled-text-field%
|
|
(parent result-pane)
|
|
(label (string-constant test-case-actual))
|
|
(show? actual-show?)
|
|
(snip-class (grey-editor-snip-mixin stretchable-editor-snip%))
|
|
(text actual))]
|
|
|
|
[right-pane (new vertical-alignment% (parent body) (show? show-right-pane?))]
|
|
[predicate-pane
|
|
(new labeled-text-field%
|
|
(parent right-pane)
|
|
(show? (not error-box?))
|
|
(label (string-constant test-case-predicate))
|
|
(text predicate))]
|
|
[error-message-pane
|
|
(new labeled-text-field%
|
|
(parent right-pane)
|
|
(show? error-box?)
|
|
(label (string-constant test-case-error-message))
|
|
(text error-message))])
|
|
|
|
(super-new (editor pb))
|
|
|
|
(set-tabbing to-test expected predicate)
|
|
(set-tabbing should-raise error-message)
|
|
|
|
;;;;;;;;;;
|
|
;; Snip class
|
|
|
|
(inherit set-snipclass)
|
|
(set-snipclass tcb-sc)))
|
|
|
|
;;;;;;;;;;
|
|
;; Snip class
|
|
|
|
;; A snip-class for the test case box
|
|
(define tcb-sc
|
|
(make-snipclass
|
|
test-case-box%
|
|
"test-case-box%"
|
|
#;
|
|
(lambda (class% f)
|
|
(let ([enabled?-box (box 0)]
|
|
[collapsed?-box (box 0)]
|
|
[error-box?-box (box 0)]
|
|
[to-test (new test-case:program-editor%)]
|
|
[expected (new test-case:program-editor%)]
|
|
[predicate (new test-case:program-editor%)]
|
|
[should-raise (new test-case:program-editor%)]
|
|
[error-message (new test-case:program-editor%)])
|
|
(send to-test read-from-file f)
|
|
(send expected read-from-file f)
|
|
(send predicate read-from-file f)
|
|
(send should-raise read-from-file f)
|
|
(send error-message read-from-file f)
|
|
(send f get enabled?-box)
|
|
(send f get collapsed?-box)
|
|
(send f get error-box?-box)
|
|
(new class%
|
|
(enabled? (= (unbox enabled?-box) 1))
|
|
(collapsed? (= (unbox collapsed?-box) 1))
|
|
(error-box? (= (unbox error-box?-box) 1))
|
|
(to-test to-test)
|
|
(expected expected)
|
|
(predicate predicate)
|
|
(should-raise should-raise)
|
|
(error-message error-message))))))
|
|
))
|
|
|
|
#;((-> void?) (-> void?) (symbols 'up 'down) . -> . snip%)
|
|
;; a snip which acts as a toggle button for rolling a window up and down
|
|
;; STATUS : Change this to derive embedded-toggle-button%
|
|
(define turn-button%
|
|
(class embedded-toggle-button%
|
|
(super-new
|
|
(images-off (cons (icon "turn-down.png") (icon "turn-down-click.png")))
|
|
(images-on (cons (icon "turn-up.png") (icon "turn-up-click.png"))))))
|
|
|
|
;; a snip which will display a pass/fail result
|
|
(define result-snip%
|
|
(class image-snip%
|
|
(inherit set-bitmap)
|
|
(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)
|
|
(set-bitmap
|
|
(memoize value
|
|
(lambda ()
|
|
(make-object bitmap%
|
|
(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 memory (make-hash-table 'equal))
|
|
(define (memoize k thunk)
|
|
(hash-table-get memory k (lambda ()
|
|
(let ([v (thunk)])
|
|
(hash-table-put! memory k v)
|
|
v))))
|
|
|
|
#;(string? . -> . string?)
|
|
;; A path to the icon given a file name
|
|
(define (icon str)
|
|
(build-path (collection-path "icons") str))
|
|
|
|
#;(string? . -> . string?)
|
|
;; A path to the icon in the test-suite given a file name
|
|
(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)))
|
|
|
|
;; a text mixin that gives the text an init arg of an initial contents
|
|
(define init-text-mixin
|
|
(mixin ((class->interface text%)) ()
|
|
(inherit insert)
|
|
(init [text ""])
|
|
(super-new)
|
|
(insert text)))
|
|
|
|
#;(boolean? . -> . (symbols 'on 'off))
|
|
;; converts a boolean to the value expected by the collapse button
|
|
(define (boolean->collapse-btn-state bool)
|
|
(if bool 'on 'off))
|
|
|
|
#;(boolean? . -> . (symbols 'on 'off))
|
|
;; converts a boolean to the value expected by the show actual button
|
|
(define (boolean->show-actual-btn-state bool)
|
|
(if bool 'off 'on))
|
|
|
|
#;((is-a?/c text%) . -> . boolean?)
|
|
;; True if the given text is empty
|
|
(define (empty-text? t)
|
|
(let ([str (send t get-text)])
|
|
(string=? str "")))
|
|
|
|
;;;;;;;;;;
|
|
;; Eaiser syntax for embedded-gui
|
|
(define (snip-wrap p snip)
|
|
(new snip-wrapper% (parent p) (snip snip)))
|
|
|
|
;; Inserts a label and a text field into the given alignment
|
|
(define labeled-text-field%
|
|
(class vertical-alignment%
|
|
(init label text (snip-class stretchable-editor-snip%))
|
|
(super-new (stretchable-height false))
|
|
(new embedded-message% (parent this) (label label))
|
|
(new snip-wrapper%
|
|
(parent this)
|
|
(snip (new snip-class
|
|
(editor text)
|
|
(min-width 80))))))
|
|
|
|
#;((union any? false?) (any? . -> . any?) . -> . (union any? false?))
|
|
;; Send the value to the function unless it 'fails' by returning false. Like haskell's bind operator.
|
|
(define (>>= value function)
|
|
(cond
|
|
[value => function]
|
|
[else false]))
|
|
)
|