180 lines
7.5 KiB
Scheme
180 lines
7.5 KiB
Scheme
(module tool mzscheme
|
|
|
|
(provide tool@)
|
|
|
|
(require
|
|
(lib "etc.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "unitsig.ss")
|
|
(lib "tool.ss" "drscheme")
|
|
(lib "framework.ss" "framework")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "snip-lib.ss" "mrlib" "private" "aligned-pasteboard")
|
|
"private/test-case-box.ss"
|
|
"private/find-scheme-menu.ss"
|
|
"private/text-syntax-object.ss"
|
|
"private/print-to-text.ss")
|
|
|
|
(define-signature menu-extentions^ ())
|
|
(define menu-extentions@
|
|
(unit/sig menu-extentions^;drscheme:tool-exports^
|
|
(import drscheme:tool^ test-case-box^)
|
|
|
|
;; This delay is set up because reset-highlighting is called immediately
|
|
;; after execution where I don't want the test-cases to be cleared.
|
|
;; STATUS: It appears that the problem this flag was created to fix has been
|
|
;; fixed and is now delaying unecessarily. I have commented out the place where
|
|
;; it is set to true, effectively turning off the feature. I'll remove the code
|
|
;; if no bugs creap in after sufficient usage.
|
|
(define delay? false)
|
|
|
|
;; This flag ensures that the test case boxes are only reset when the need
|
|
;; to be, which is only once after each execution of the program.
|
|
(define needs-reset? false)
|
|
|
|
;; Adds the test suite tool menu to the Dr. Scheme frame
|
|
;; Updates the needs-reset? when the the program is executed
|
|
(define test-case-mixin
|
|
(mixin (drscheme:unit:frame<%> top-level-window<%> (class->interface frame%)) ()
|
|
(inherit get-definitions-text get-edit-target-object get-menu-bar
|
|
get-special-menu)
|
|
|
|
#;(-> void)
|
|
;; Called when the program is executed
|
|
;; Overriden to rest the test-cases.
|
|
(define/override (execute-callback)
|
|
(send (get-definitions-text) for-each-test-case
|
|
(lambda (case) (send case reset)))
|
|
(super execute-callback)
|
|
;(set! delay? true)
|
|
(set! needs-reset? true))
|
|
|
|
#;(boolean . -> . void)
|
|
;; Enable or disable all of the test-cases
|
|
(define (enable enable?)
|
|
(send (get-definitions-text) for-each-test-case
|
|
(lambda (case) (send case enable enable?))))
|
|
|
|
#;((is-a?/c menu-item%) . -> . void)
|
|
;; NOTE: This function is COPIED from the drscheme/private/unit.ss file
|
|
(define (has-editor-on-demand menu-item)
|
|
(let ([edit (get-edit-target-object)])
|
|
(send menu-item enable (and edit (is-a? edit editor<%>)))))
|
|
|
|
(super-new)
|
|
|
|
;; Create the new menu items.
|
|
(field
|
|
[test-cases-enabled? true]
|
|
[insert-menu-item
|
|
(new menu-item%
|
|
(label (string-constant test-case-insert))
|
|
(parent (get-special-menu))
|
|
(callback
|
|
(lambda (menu event)
|
|
(let ([test-box (new test-case-box% (enabled? test-cases-enabled?))]
|
|
[text (get-edit-target-object)])
|
|
(when text
|
|
(send text begin-edit-sequence)
|
|
(send text insert test-box)
|
|
(send test-box take-caret)
|
|
(send text end-edit-sequence)))))
|
|
(demand-callback has-editor-on-demand))])
|
|
(let ([parent (find-scheme-menu (get-special-menu))])
|
|
(and parent
|
|
(new menu-item%
|
|
(parent parent)
|
|
(label (string-constant test-case-disable-all))
|
|
(callback
|
|
(lambda (menu event)
|
|
(set! test-cases-enabled? (not test-cases-enabled?))
|
|
(if test-cases-enabled?
|
|
(send menu set-label (string-constant test-case-disable-all))
|
|
(send menu set-label (string-constant test-case-enable-all)))
|
|
(send (get-definitions-text) for-each-test-case
|
|
(lambda (tc) (send tc enable test-cases-enabled?))))))))))
|
|
|
|
(drscheme:get/extend:extend-unit-frame test-case-mixin)
|
|
|
|
;; Adds a hook in the reset-highlighting to clear all of the test-case results when
|
|
;; the appropriate
|
|
;; STATUS: It's better to override reset-highlighting but this after-insert/delete works
|
|
;; for now.
|
|
(define clear-results-mixin
|
|
(mixin (editor<%>) ()
|
|
(inherit find-first-snip)
|
|
|
|
;#;(case-> (-> boolean?) (boolean? . -> . void))
|
|
;;; Get or set the delay-reset field
|
|
;(define/public delay-reset
|
|
; (case-lambda
|
|
; [() delay?]
|
|
; [(v) (set! delay? v)]))
|
|
|
|
#;(-> void)
|
|
;; set all of the test-case-boxes in the definitions text to an unevaluated state
|
|
(define/public (reset-test-case-boxes)
|
|
(when needs-reset?
|
|
(set! needs-reset? false)
|
|
(for-each-test-case (lambda (snip) (send snip reset)))))
|
|
|
|
#;(((is-a?/c test-case-box%) . -> . void) . -> . void)
|
|
;; executes the given function on each test-case-box
|
|
(define/public (for-each-test-case f)
|
|
(for-each-snip
|
|
(lambda (snip)
|
|
(when (is-a? snip test-case-box%)
|
|
(f snip)))
|
|
(find-first-snip)))
|
|
|
|
(super-new)))
|
|
|
|
(drscheme:get/extend:extend-definitions-text clear-results-mixin)
|
|
|
|
;; Require the test-case macro into every new namespace when a program is run.
|
|
(define require-macro-mixin
|
|
(mixin ((class->interface drscheme:rep:text%)) ()
|
|
(inherit get-user-namespace get-definitions-text)
|
|
|
|
#;((is-a?/c area<%>) . -> . (is-a?/c frame%))
|
|
;; The frame containing the given area
|
|
(define (find-frame area)
|
|
(let ([parent (send area get-parent)])
|
|
(if parent
|
|
(find-frame parent)
|
|
area)))
|
|
|
|
#;(-> void)
|
|
;; Called to indicate that the program annotations should be cleared.
|
|
;; Overriden to reset test case boxes
|
|
(define/override (reset-highlighting)
|
|
(super reset-highlighting)
|
|
(let ([defs-text (get-definitions-text)])
|
|
;(if (send text delay-reset)
|
|
; (send text delay-reset false)
|
|
; (send text reset-test-case-boxes))))
|
|
(send defs-text reset-test-case-boxes)))
|
|
|
|
#;(-> void)
|
|
;; Called when the program is execute to reset the rep:text
|
|
;; Overriden to require the test case macro into any program that is executed.
|
|
(define/override (reset-console)
|
|
(super reset-console)
|
|
(parameterize ([current-namespace (get-user-namespace)])
|
|
(namespace-require '(lib "test-case.ss" "test-suite" "private"))))
|
|
(super-new)))
|
|
|
|
(drscheme:get/extend:extend-interactions-text require-macro-mixin)))
|
|
|
|
(define tool@
|
|
(compound-unit/sig
|
|
(import (TOOL : drscheme:tool^))
|
|
(link (MENU : menu-extentions^ (menu-extentions@ TOOL CASE))
|
|
(CASE : test-case-box^ (test-case-box@ TOOL SYNTAX PRINT))
|
|
(SYNTAX : text->syntax-object^ (text->syntax-object@ TOOL))
|
|
(PRINT : print-to-text^ (print-to-text@ TOOL)))
|
|
(export (var (CASE phase1))
|
|
(var (CASE phase2)))))
|
|
)
|