suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

various changes

Browse Source 
- 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 2008-02-24 05:43:13 +00:00
parent d4ec7ac06a
commit 25a6c70202
5 changed files with 125 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/frtime/demos/gui/fred.ss
View File

@ -63,6 +63,8 @@
(define (send-for-selection w e) (define (send-for-selection w e)
(send w get-selection)) (send w get-selection))
(define (send-for-selections w e)
(send w get-selections))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make state available as eventstreams ;; make state available as eventstreams
@ -144,11 +146,33 @@
(super-new (callback-events-event-processor (super-new (callback-events-event-processor
(lambda (es) (map-e (lambda (e) (apply val-ext e)) es))))))) (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-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 ;; using events to drive object interaction
@ -203,7 +227,15 @@
(add-value-b (add-value-b
(accessor val-ext super-class)))) (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% (define ft-frame%
((behavior->callbacks shown show) ((behavior->callbacks shown show)
@ -230,16 +262,22 @@
(standard-lift text-field%))) (standard-lift text-field%)))
(define ft-radio-box% (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%)))) (add-void-set-value (standard-lift radio-box%))))
(define ft-choice% (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%)))) (add-void-set-value (standard-lift choice%))))
(define ft-list-box% (define ft-list-box%
((standard-input-lift add-callback-access send-for-selection) (class ((selections-input-lift add-callback-access/selections send-for-selections)
(add-void-set-value (standard-lift list-box%)))) (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))))))

40
collects/frtime/frp-snip.ss
View File

@ -69,27 +69,28 @@
(super-instantiate (" ")))) (super-instantiate (" "))))
(define dynamic-snip-copy% (define dynamic-snip-copy%
(class snip% (class editor-snip%
(init-field current parent) (init-field current parent)
(inherit get-admin) (inherit get-editor)
(define/public (set-current c) (define/public (set-current c)
(parameterize ([current-eventspace drs-eventspace]) (parameterize ([current-eventspace drs-eventspace])
(queue-callback (queue-callback
(lambda () (lambda ()
(set! current c) (send (get-editor) lock #f)
(let ([admin (get-admin)]) (send (get-editor) delete 0 (send (get-editor) last-position))
(when admin (for-each (lambda (thing)
(send admin resized this #t))))))) (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) (super-new
(send current size-cache-invalid)) [with-border? #f]
[left-margin 0]
(define/override (get-extent dc x y w h descent space lspace rspace) [right-margin 0]
(send current get-extent dc x y w h descent space lspace rspace)) [top-margin 0]
[bottom-margin 0])
(define/override (draw dc x y left top right bottom dx dy draw-caret) (set-current current)))
(send current draw dc x y left top right bottom dx dy draw-caret))
(super-new)))
(define dynamic-snip% (define dynamic-snip%
(class snip% (class snip%
@ -140,17 +141,14 @@
(thread (lambda () (super-render-fun val out) (close-output-port out))) (thread (lambda () (super-render-fun val out) (close-output-port out)))
(let loop ([chars empty]) (let loop ([chars empty])
(let ([c (read-char-or-special in)]) (let ([c (read-char-or-special in)])
;(fprintf (current-error-port) "read ~a~n" c) (if (eof-object? c)
(cond (reverse (rest chars))
[(eof-object? c) (make-object string-snip% (list->string (reverse (rest chars))))] (loop (cons c chars)))))))
[(char? c) (loop (cons c chars))]
[else c])))))
(define (watch beh super-render-fun) (define (watch beh super-render-fun)
(cond (cond
[(undefined? beh) [(undefined? beh)
(begin (begin
;(printf "~a was regarded as undefined~n" beh)
(make-object string-snip% "<undefined>") (make-object string-snip% "<undefined>")
) )
] ]

73
collects/gui-debugger/debug-tool.ss
View File

@ -112,16 +112,18 @@
(truncate-value (vector-ref v i) size (sub1 depth)))))] (truncate-value (vector-ref v i) size (sub1 depth)))))]
[else v])) [else v]))
(define (filename->defs source) (define filename->defs
(if (is-a? source editor<%>) (opt-lambda (source [default #f])
source
(cond (cond
[(and source (send (group:get-the-frame-group) locate-file source)) [(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) (lambda (frame)
(let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))]) (let ([defss (map (lambda (t) (send t get-defs)) (send frame get-tabs))])
(findf (lambda (d) (equal? (send d get-filename) source)) defss)))] (findf (lambda (d) (equal? (send d get-filename) source)) defss)))]
[else #f]))) [else default])))
(define (debug-definitions-text-mixin super%) (define (debug-definitions-text-mixin super%)
(class super% (class super%
@ -140,7 +142,7 @@
(define bp-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (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-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-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)) 'solid))
(define bp-tmp-pen (send the-pen-list find-or-create-pen "black" 1 '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" (define bp-tmp-brush (send the-brush-list find-or-create-brush "yellow"
@ -354,9 +356,18 @@
(cons 'exit-break (cons 'exit-break
(call-with-values (call-with-values
(lambda () (lambda ()
(with-handlers ([exn:fail? k]) ; LATER: message box (with-handlers
(eval-string tmp))) ([exn:fail?
list)))))))))) (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% (make-object menu-item%
"Continue to this point" "Continue to this point"
menu menu
@ -398,7 +409,16 @@
(format "New value for ~a" id-sym) #f #f (format "New value for ~a" id-sym) #f #f
(format "~a" val))]) (format "~a" val))])
(when tmp (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 (send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor (send event get-x)))) (+ 1 (inexact->exact (floor (send event get-x))))
(+ 1 (inexact->exact (floor (send event get-y))))) (+ 1 (inexact->exact (floor (send event get-y)))))
@ -573,23 +593,29 @@
; record-bound-identifier ; record-bound-identifier
(lambda (type bound binding) (lambda (type bound binding)
;(display-results (list bound)) ;(display-results (list bound))
(when (eq? (robust-syntax-source bound) source) (cond
[(filename->defs (robust-syntax-source bound))
=>
(lambda (defs)
(let ([pos-vec (send (send defs get-tab) get-pos-vec)])
(let loop ([i 0]) (let loop ([i 0])
(when (< i (syntax-span bound)) (when (< i (syntax-span bound))
(safe-vector-set! pos-vec (+ i (syntax-position bound)) binding) (safe-vector-set! pos-vec (+ i (syntax-position bound))
(loop (add1 i)))))) binding)
(loop (add1 i))))))]
[else (void)]))
; record-top-level-identifier ; record-top-level-identifier
(lambda (mod var val) (lambda (mod var rd/wr)
; filename->defs should succeed unless a slave tab gets closed ; filename->defs should succeed unless a slave tab gets closed
(cond (cond
[(filename->defs source) [(filename->defs (robust-syntax-source var))
=> =>
(lambda (defs) (lambda (defs)
(send (send defs get-tab) (send (send defs get-tab)
add-top-level-binding var val))] add-top-level-binding var rd/wr))]
[else (void) #;(printf "record-top-level failed~n")]) [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)]) source)])
(hash-table-for-each (hash-table-for-each
breakpoints breakpoints
@ -630,7 +656,8 @@
(current-eval) (current-eval)
; break? -- curried to avoid looking up defs from source each time ; break? -- curried to avoid looking up defs from source each time
(lambda (src) (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 [breakpoints
(if src (if src
(send src-tab get-breakpoints) (send src-tab get-breakpoints)
@ -683,6 +710,7 @@
[slaves empty] [slaves empty]
[closed? (box #f)] [closed? (box #f)]
[stack-frames (box #f)] [stack-frames (box #f)]
[frame-num 0]
[break-status (box #f)] [break-status (box #f)]
[current-language-settings #f] [current-language-settings #f]
[pos-vec (vector #f)] [pos-vec (vector #f)]
@ -720,8 +748,8 @@
(define/public (get-single-step-box) single-step?) (define/public (get-single-step-box) single-step?)
(define/public (set-single-step?! v) (set-box! single-step? v)) (define/public (set-single-step?! v) (set-box! single-step? v))
(define/public (set-break-status stat) (set-box! break-status stat)) (define/public (set-break-status stat) (set-box! break-status stat))
(define/public (add-top-level-binding var val) (define/public (add-top-level-binding var rd/wr)
(set! top-level-bindings (cons (cons var val) top-level-bindings))) (set! top-level-bindings (cons (cons var rd/wr) top-level-bindings)))
(define/public (lookup-top-level-var var failure-thunk) (define/public (lookup-top-level-var var failure-thunk)
#; #;
(printf "looking for ~a in ~a~n" var top-level-bindings) (printf "looking for ~a in ~a~n" var top-level-bindings)
@ -1068,7 +1096,8 @@
(let/ec k (let/ec k
(let* ([stx (mark-source f)] (let* ([stx (mark-source f)]
[src (syntax-source stx)] [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)] [defs (filename->defs src)]
[tab (if defs (send defs get-tab) (k (begin #;(printf "no defs for ~a~n" src) #f)))] [tab (if defs (send defs get-tab) (k (begin #;(printf "no defs for ~a~n" src) #f)))]
[bps (send tab get-breakpoints)] [bps (send tab get-breakpoints)]

2
collects/gui-debugger/info.ss
View File

@ -3,4 +3,4 @@
(define name "Graphical Debugger") (define name "Graphical Debugger")
(define tools '(("debug-tool.ss"))) (define tools '(("debug-tool.ss")))
(define tool-names '("Graphical Debugger")) (define tool-names '("Graphical Debugger"))
(define tool-icons '(("emblem-ohno.png" "gui-debugger" "icons"))) (define tool-icons '(("icon-big.png" "gui-debugger" "icons")))

4
collects/lang/htdp-langs.ss
View File

@ -842,7 +842,8 @@
(define (debugger-settings-language %) (define (debugger-settings-language %)
(if (implementation? % debugger-language<%>) (if (implementation? % debugger-language<%>)
(class* % (debugger-language<%>) (class* % (debugger-language<%>)
(define/override (debugger:supported?) #f) (init-field [debugger:supported #f])
(define/override (debugger:supported?) debugger:supported)
(super-new)) (super-new))
%)) %))
@ -1296,6 +1297,7 @@
(abbreviate-cons-as-list #t) (abbreviate-cons-as-list #t)
(allow-sharing? #t) (allow-sharing? #t)
(reader-module '(lib "htdp-advanced-reader.ss" "lang")) (reader-module '(lib "htdp-advanced-reader.ss" "lang"))
(debugger:supported #t)
(stepper:supported #f) (stepper:supported #f)
(stepper:enable-let-lifting #t) (stepper:enable-let-lifting #t)
(stepper:show-lambdas-as-lambdas #t))) (stepper:show-lambdas-as-lambdas #t)))