From 25a6c702026fa3ffefbfbd4b75cdd663354996a5 Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Sun, 24 Feb 2008 05:43:13 +0000 Subject: [PATCH] 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 --- collects/frtime/demos/gui/fred.ss | 50 +++++++++++++++-- collects/frtime/frp-snip.ss | 40 +++++++------ collects/gui-debugger/debug-tool.ss | 87 +++++++++++++++++++---------- collects/gui-debugger/info.ss | 2 +- collects/lang/htdp-langs.ss | 4 +- 5 files changed, 125 insertions(+), 58 deletions(-) diff --git a/collects/frtime/demos/gui/fred.ss b/collects/frtime/demos/gui/fred.ss index 3d1bb85573..d441a2322d 100644 --- a/collects/frtime/demos/gui/fred.ss +++ b/collects/frtime/demos/gui/fred.ss @@ -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) diff --git a/collects/frtime/frp-snip.ss b/collects/frtime/frp-snip.ss index 04d5ea053f..9fba0cb7b1 100644 --- a/collects/frtime/frp-snip.ss +++ b/collects/frtime/frp-snip.ss @@ -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% "") ) ] diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss index 8d9075b134..dfcbe32cb7 100644 --- a/collects/gui-debugger/debug-tool.ss +++ b/collects/gui-debugger/debug-tool.ss @@ -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)] diff --git a/collects/gui-debugger/info.ss b/collects/gui-debugger/info.ss index b851ad7e61..db4312ece6 100644 --- a/collects/gui-debugger/info.ss +++ b/collects/gui-debugger/info.ss @@ -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"))) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 8370fc58c6..219c0b2b58 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -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)))