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

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

@ -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
@ -143,12 +145,34 @@
(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/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))))))
@ -250,7 +288,7 @@
(define specialized-gauge%
(add-signal-controls
(class gauge%
(init value)
(init value)
(super-new)
(send this set-value value))
(value set-value 0)

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

@ -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>")
)
]

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

@ -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)]

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

@ -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")))

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

@ -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)))