91 lines
3.3 KiB
Scheme
91 lines
3.3 KiB
Scheme
|
|
(module get-extend mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
"drsig.ss"
|
|
(lib "mred.ss" "mred")
|
|
(lib "etc.ss"))
|
|
|
|
(provide get-extend@)
|
|
|
|
(define get-extend@
|
|
(unit/sig drscheme:get/extend^
|
|
|
|
(import [drscheme:unit : drscheme:unit^]
|
|
[drscheme:frame : drscheme:frame^]
|
|
[drscheme:rep : drscheme:rep^]
|
|
[drscheme:debug : drscheme:debug^])
|
|
|
|
(define make-extender
|
|
(λ (get-base% name)
|
|
(let ([extensions (λ (x) x)]
|
|
[built-yet? #f]
|
|
[built #f]
|
|
[verify
|
|
(λ (f)
|
|
(λ (%)
|
|
(let ([new% (f %)])
|
|
(if (and (class? new%)
|
|
(subclass? new% %))
|
|
new%
|
|
(error 'extend-% "expected output of extension to create a subclass of its input, got: ~a"
|
|
new%)))))])
|
|
(values
|
|
(rec add-extender
|
|
(case-lambda
|
|
[(extension) (add-extender extension #t)]
|
|
[(extension before?)
|
|
(when built-yet?
|
|
(error 'extender "cannot build a new extension of ~a after initialization"
|
|
name))
|
|
(set! extensions
|
|
(if before?
|
|
(compose (verify extension) extensions)
|
|
(compose extensions (verify extension))))]))
|
|
(λ ()
|
|
(unless built-yet?
|
|
(set! built-yet? #t)
|
|
(set! built (extensions (get-base%))))
|
|
built)))))
|
|
|
|
(define (get-base-tab%)
|
|
(drscheme:debug:test-coverage-tab-mixin
|
|
(drscheme:debug:profile-tab-mixin
|
|
drscheme:unit:tab%)))
|
|
|
|
(define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%))
|
|
|
|
(define (get-base-interactions-canvas%)
|
|
drscheme:unit:interactions-canvas%)
|
|
|
|
(define-values (extend-interactions-canvas get-interactions-canvas)
|
|
(make-extender get-base-interactions-canvas% 'interactions-canvas%))
|
|
|
|
(define (get-base-definitions-canvas%)
|
|
drscheme:unit:definitions-canvas%)
|
|
|
|
(define-values (extend-definitions-canvas get-definitions-canvas)
|
|
(make-extender get-base-definitions-canvas% 'definitions-canvas%))
|
|
|
|
(define (get-base-unit-frame%)
|
|
(drscheme:debug:profile-unit-frame-mixin
|
|
drscheme:unit:frame%))
|
|
|
|
(define-values (extend-unit-frame get-unit-frame)
|
|
(make-extender get-base-unit-frame% 'drscheme:unit:frame))
|
|
|
|
(define (get-base-interactions-text%)
|
|
(drscheme:debug:test-coverage-interactions-text-mixin
|
|
drscheme:rep:text%))
|
|
|
|
(define-values (extend-interactions-text get-interactions-text)
|
|
(make-extender get-base-interactions-text% 'interactions-text%))
|
|
|
|
(define (get-base-definitions-text%)
|
|
(drscheme:debug:test-coverage-definitions-text-mixin
|
|
(drscheme:debug:profile-definitions-text-mixin
|
|
(drscheme:unit:get-definitions-text%))))
|
|
|
|
(define-values (extend-definitions-text get-definitions-text)
|
|
(make-extender get-base-definitions-text% 'definitions-text%)))))
|