various changes
- use an editor-snip% to make frtime's value rendering work correctly (though not as prettily) when several snips are embedded within a data structure - fix frtime's choice, radio-box, and list-box widgets - improve debugger's handling of variables, etc. - allow HtDP languages to enable the debugger, and do so for Advanced language svn: r8780
This commit is contained in:
Greg Cooper
parent
d4ec7ac06a
commit
25a6c70202
|
|
@ -63,6 +63,8 @@
|
|||
(define (send-for-selection w e)
|
||||
(send w get-selection))
|
||||
|
||||
(define (send-for-selections w e)
|
||||
(send w get-selections))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; make state available as eventstreams
|
||||
|
|
@ -144,11 +146,33 @@
|
|||
(super-new (callback-events-event-processor
|
||||
(lambda (es) (map-e (lambda (e) (apply val-ext e)) es)))))))
|
||||
|
||||
(define (add-callback-access/selection val-ext super-class)
|
||||
((mixin-merge-e
|
||||
selection-e
|
||||
get-set-value-events
|
||||
get-callback-events)
|
||||
(class (monitor-set-value
|
||||
(monitor-callback-method
|
||||
(callback->pub-meth super-class)))
|
||||
(super-new (callback-events-event-processor
|
||||
(lambda (es) (map-e (lambda (e) (apply val-ext e)) es)))))))
|
||||
|
||||
(define (add-callback-access/selections val-ext super-class)
|
||||
((mixin-merge-e
|
||||
selections-e
|
||||
get-set-value-events
|
||||
get-callback-events)
|
||||
(class (monitor-set-value
|
||||
(monitor-callback-method
|
||||
(callback->pub-meth super-class)))
|
||||
(super-new (callback-events-event-processor
|
||||
(lambda (es) (map-e (lambda (e) (apply val-ext e)) es)))))))
|
||||
|
||||
(define add-value-b (mixin-hold value-b get-value get-value-e))
|
||||
|
||||
(define add-selection-b (mixin-hold selection-b get-selection get-selection-e))
|
||||
|
||||
|
||||
(define add-selections-b (mixin-hold selections-b get-selections get-selections-e))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; using events to drive object interaction
|
||||
|
|
@ -203,7 +227,15 @@
|
|||
(add-value-b
|
||||
(accessor val-ext super-class))))
|
||||
|
||||
(define (selection-input-lift accessor val-ext)
|
||||
(lambda (super-class)
|
||||
(add-selection-b
|
||||
(accessor val-ext super-class))))
|
||||
|
||||
(define (selections-input-lift accessor val-ext)
|
||||
(lambda (super-class)
|
||||
(add-selections-b
|
||||
(accessor val-ext super-class))))
|
||||
|
||||
(define ft-frame%
|
||||
((behavior->callbacks shown show)
|
||||
|
|
@ -230,16 +262,22 @@
|
|||
(standard-lift text-field%)))
|
||||
|
||||
(define ft-radio-box%
|
||||
((standard-input-lift add-callback-access send-for-selection)
|
||||
((selection-input-lift add-callback-access/selection send-for-selection)
|
||||
(add-void-set-value (standard-lift radio-box%))))
|
||||
|
||||
(define ft-choice%
|
||||
((standard-input-lift add-callback-access send-for-selection)
|
||||
((selection-input-lift add-callback-access/selection send-for-selection)
|
||||
(add-void-set-value (standard-lift choice%))))
|
||||
|
||||
(define ft-list-box%
|
||||
((standard-input-lift add-callback-access send-for-selection)
|
||||
(add-void-set-value (standard-lift list-box%))))
|
||||
(class ((selections-input-lift add-callback-access/selections send-for-selections)
|
||||
(add-void-set-value (standard-lift list-box%)))
|
||||
(super-new)
|
||||
(define/public (get-selection-b)
|
||||
(let ([selections-b (send this get-selections-b)])
|
||||
(if (null? selections-b)
|
||||
#f
|
||||
(car selections-b))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -69,27 +69,28 @@
|
|||
(super-instantiate (" "))))
|
||||
|
||||
(define dynamic-snip-copy%
|
||||
(class snip%
|
||||
(class editor-snip%
|
||||
(init-field current parent)
|
||||
(inherit get-admin)
|
||||
(inherit get-editor)
|
||||
(define/public (set-current c)
|
||||
(parameterize ([current-eventspace drs-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(set! current c)
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(send admin resized this #t)))))))
|
||||
(send (get-editor) lock #f)
|
||||
(send (get-editor) delete 0 (send (get-editor) last-position))
|
||||
(for-each (lambda (thing)
|
||||
(send (get-editor) insert thing
|
||||
(send (get-editor) last-position) (send (get-editor) last-position)))
|
||||
c)
|
||||
(send (get-editor) lock #t)))))
|
||||
|
||||
(define/override (size-cache-invalid)
|
||||
(send current size-cache-invalid))
|
||||
|
||||
(define/override (get-extent dc x y w h descent space lspace rspace)
|
||||
(send current get-extent dc x y w h descent space lspace rspace))
|
||||
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(send current draw dc x y left top right bottom dx dy draw-caret))
|
||||
(super-new)))
|
||||
(super-new
|
||||
[with-border? #f]
|
||||
[left-margin 0]
|
||||
[right-margin 0]
|
||||
[top-margin 0]
|
||||
[bottom-margin 0])
|
||||
(set-current current)))
|
||||
|
||||
(define dynamic-snip%
|
||||
(class snip%
|
||||
|
|
@ -140,17 +141,14 @@
|
|||
(thread (lambda () (super-render-fun val out) (close-output-port out)))
|
||||
(let loop ([chars empty])
|
||||
(let ([c (read-char-or-special in)])
|
||||
;(fprintf (current-error-port) "read ~a~n" c)
|
||||
(cond
|
||||
[(eof-object? c) (make-object string-snip% (list->string (reverse (rest chars))))]
|
||||
[(char? c) (loop (cons c chars))]
|
||||
[else c])))))
|
||||
(if (eof-object? c)
|
||||
(reverse (rest chars))
|
||||
(loop (cons c chars)))))))
|
||||
|
||||
(define (watch beh super-render-fun)
|
||||
(cond
|
||||
[(undefined? beh)
|
||||
(begin
|
||||
;(printf "~a was regarded as undefined~n" beh)
|
||||
(make-object string-snip% "<undefined>")
|
||||
)
|
||||
]
|
||||
|
|
|
|||
|
|
@ -112,16 +112,18 @@
|
|||
(truncate-value (vector-ref v i) size (sub1 depth)))))]
|
||||
[else v]))
|
||||
|
||||
(define (filename->defs source)
|
||||
(if (is-a? source editor<%>)
|
||||
source
|
||||
(cond
|
||||
[(and source (send (group:get-the-frame-group) locate-file source))
|
||||
=>
|
||||
(lambda (frame)
|
||||
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
|
||||
(findf (lambda (d) (equal? (send d get-filename) source)) defss)))]
|
||||
[else #f])))
|
||||
(define filename->defs
|
||||
(opt-lambda (source [default #f])
|
||||
(cond
|
||||
[(is-a? source editor<%>) source]
|
||||
[(or (not source) (symbol? source)) #f]
|
||||
[(and source (not (symbol? source))
|
||||
(send (group:get-the-frame-group) locate-file source))
|
||||
=>
|
||||
(lambda (frame)
|
||||
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
|
||||
(findf (lambda (d) (equal? (send d get-filename) source)) defss)))]
|
||||
[else default])))
|
||||
|
||||
(define (debug-definitions-text-mixin super%)
|
||||
(class super%
|
||||
|
|
@ -140,7 +142,7 @@
|
|||
(define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(define bp-brush (send the-brush-list find-or-create-brush "red" 'solid))
|
||||
(define bp-mo-pen (send the-pen-list find-or-create-pen "darkgray" 1 'solid))
|
||||
(define bp-mo-brush (send the-brush-list find-or-create-brush "pink"
|
||||
(define bp-mo-brush (send the-brush-list find-or-create-brush "tomato"
|
||||
'solid))
|
||||
(define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
|
||||
(define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
|
||||
|
|
@ -354,9 +356,18 @@
|
|||
(cons 'exit-break
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-handlers ([exn:fail? k]) ; LATER: message box
|
||||
(eval-string tmp)))
|
||||
list))))))))))
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
"Debugger Error"
|
||||
(format "An error occurred: ~a" (exn-message exn))
|
||||
#f
|
||||
'(ok))
|
||||
(k))])
|
||||
(read (open-input-string tmp))))
|
||||
list)))
|
||||
(invalidate-bitmap-cache))))))))
|
||||
(make-object menu-item%
|
||||
"Continue to this point"
|
||||
menu
|
||||
|
|
@ -398,7 +409,16 @@
|
|||
(format "New value for ~a" id-sym) #f #f
|
||||
(format "~a" val))])
|
||||
(when tmp
|
||||
(wr (eval-string tmp))))))
|
||||
(let/ec k
|
||||
(wr (with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(message-box
|
||||
"Debugger Error"
|
||||
(format "The following error occurred: ~a"
|
||||
(exn-message exn)))
|
||||
(k))])
|
||||
(read (open-input-string tmp)))))))))
|
||||
(send (get-canvas) popup-menu menu
|
||||
(+ 1 (inexact->exact (floor (send event get-x))))
|
||||
(+ 1 (inexact->exact (floor (send event get-y)))))
|
||||
|
|
@ -573,23 +593,29 @@
|
|||
; record-bound-identifier
|
||||
(lambda (type bound binding)
|
||||
;(display-results (list bound))
|
||||
(when (eq? (robust-syntax-source bound) source)
|
||||
(let loop ([i 0])
|
||||
(when (< i (syntax-span bound))
|
||||
(safe-vector-set! pos-vec (+ i (syntax-position bound)) binding)
|
||||
(loop (add1 i))))))
|
||||
(cond
|
||||
[(filename->defs (robust-syntax-source bound))
|
||||
=>
|
||||
(lambda (defs)
|
||||
(let ([pos-vec (send (send defs get-tab) get-pos-vec)])
|
||||
(let loop ([i 0])
|
||||
(when (< i (syntax-span bound))
|
||||
(safe-vector-set! pos-vec (+ i (syntax-position bound))
|
||||
binding)
|
||||
(loop (add1 i))))))]
|
||||
[else (void)]))
|
||||
; record-top-level-identifier
|
||||
(lambda (mod var val)
|
||||
(lambda (mod var rd/wr)
|
||||
; filename->defs should succeed unless a slave tab gets closed
|
||||
(cond
|
||||
[(filename->defs source)
|
||||
[(filename->defs (robust-syntax-source var))
|
||||
=>
|
||||
(lambda (defs)
|
||||
(send (send defs get-tab)
|
||||
add-top-level-binding var val))]
|
||||
[else (void) #;(printf "record-top-level failed~n")])
|
||||
add-top-level-binding var rd/wr))]
|
||||
[else #;(printf "record-top-level failed for ~a~n" var) (void)])
|
||||
#;
|
||||
(printf "top-level binding: ~a ~a ~a~n" mod var val))
|
||||
(printf "top-level binding: ~a ~a ~a~n" mod var rd/wr))
|
||||
source)])
|
||||
(hash-table-for-each
|
||||
breakpoints
|
||||
|
|
@ -630,7 +656,8 @@
|
|||
(current-eval)
|
||||
; break? -- curried to avoid looking up defs from source each time
|
||||
(lambda (src)
|
||||
(let* ([src-tab (send (filename->defs src) get-tab)]
|
||||
(let* ([defs (filename->defs src)]
|
||||
[src-tab (if defs (send defs get-tab) (get-tab))]
|
||||
[breakpoints
|
||||
(if src
|
||||
(send src-tab get-breakpoints)
|
||||
|
|
@ -683,6 +710,7 @@
|
|||
[slaves empty]
|
||||
[closed? (box #f)]
|
||||
[stack-frames (box #f)]
|
||||
[frame-num 0]
|
||||
[break-status (box #f)]
|
||||
[current-language-settings #f]
|
||||
[pos-vec (vector #f)]
|
||||
|
|
@ -720,8 +748,8 @@
|
|||
(define/public (get-single-step-box) single-step?)
|
||||
(define/public (set-single-step?! v) (set-box! single-step? v))
|
||||
(define/public (set-break-status stat) (set-box! break-status stat))
|
||||
(define/public (add-top-level-binding var val)
|
||||
(set! top-level-bindings (cons (cons var val) top-level-bindings)))
|
||||
(define/public (add-top-level-binding var rd/wr)
|
||||
(set! top-level-bindings (cons (cons var rd/wr) top-level-bindings)))
|
||||
(define/public (lookup-top-level-var var failure-thunk)
|
||||
#;
|
||||
(printf "looking for ~a in ~a~n" var top-level-bindings)
|
||||
|
|
@ -1068,7 +1096,8 @@
|
|||
(let/ec k
|
||||
(let* ([stx (mark-source f)]
|
||||
[src (syntax-source stx)]
|
||||
[pos (+ (syntax-position stx) (syntax-span stx) -1)]
|
||||
[lpos (or (syntax-position stx) (k #f))]
|
||||
[pos (+ lpos (syntax-span stx) -1)]
|
||||
[defs (filename->defs src)]
|
||||
[tab (if defs (send defs get-tab) (k (begin #;(printf "no defs for ~a~n" src) #f)))]
|
||||
[bps (send tab get-breakpoints)]
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@
|
|||
(define name "Graphical Debugger")
|
||||
(define tools '(("debug-tool.ss")))
|
||||
(define tool-names '("Graphical Debugger"))
|
||||
(define tool-icons '(("emblem-ohno.png" "gui-debugger" "icons")))
|
||||
(define tool-icons '(("icon-big.png" "gui-debugger" "icons")))
|
||||
|
|
|
|||
|
|
@ -842,7 +842,8 @@
|
|||
(define (debugger-settings-language %)
|
||||
(if (implementation? % debugger-language<%>)
|
||||
(class* % (debugger-language<%>)
|
||||
(define/override (debugger:supported?) #f)
|
||||
(init-field [debugger:supported #f])
|
||||
(define/override (debugger:supported?) debugger:supported)
|
||||
(super-new))
|
||||
%))
|
||||
|
||||
|
|
@ -1296,6 +1297,7 @@
|
|||
(abbreviate-cons-as-list #t)
|
||||
(allow-sharing? #t)
|
||||
(reader-module '(lib "htdp-advanced-reader.ss" "lang"))
|
||||
(debugger:supported #t)
|
||||
(stepper:supported #f)
|
||||
(stepper:enable-let-lifting #t)
|
||||
(stepper:show-lambdas-as-lambdas #t)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user