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

fixed #i printing

Browse Source 
svn: r15993
This commit is contained in:
John Clements 2009-09-13 18:35:21 +00:00
parent 4510c0339f
commit 7bb15bbbeb
3 changed files with 692 additions and 672 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1098
collects/stepper/private/mred-extensions.ss
View File

File diff suppressed because it is too large Load Diff

172
collects/stepper/stepper-tool.ss
View File

@ -11,6 +11,7 @@
(prefix-in x: "private/mred-extensions.ss") (prefix-in x: "private/mred-extensions.ss")
"private/shared.ss" "private/shared.ss"
lang/stepper-language-interface lang/stepper-language-interface
scheme/pretty
"xml-sig.ss") "xml-sig.ss")
(import drscheme:tool^ xml^ view-controller^) (import drscheme:tool^ xml^ view-controller^)
@ -18,7 +19,6 @@
;; tool magic here: ;; tool magic here:
(define (phase1) (define (phase1)
;; experiment with extending the language... parameter-like fields for stepper parameters ;; experiment with extending the language... parameter-like fields for stepper parameters
(drscheme:language:extend-language-interface (drscheme:language:extend-language-interface
stepper-language<%> stepper-language<%>
@ -26,21 +26,27 @@
(class* superclass (stepper-language<%>) (class* superclass (stepper-language<%>)
(public stepper:supported?) (public stepper:supported?)
(define (stepper:supported?) #f) (define (stepper:supported?) #f)
(public stepper:enable-let-lifting?) (public stepper:enable-let-lifting?)
(define (stepper:enable-let-lifting?) #f) (define (stepper:enable-let-lifting?) #f)
(public stepper:show-lambdas-as-lambdas?) (public stepper:show-lambdas-as-lambdas?)
(define (stepper:show-lambdas-as-lambdas?) #t) (define (stepper:show-lambdas-as-lambdas?) #t)
(public stepper:show-inexactness?)
(define (stepper:show-inexactness?) #t)
(public stepper:render-to-sexp) (public stepper:render-to-sexp)
(define (stepper:render-to-sexp val settings language-level) (define (stepper:render-to-sexp val settings language-level)
(parameterize ([current-print-convert-hook stepper-print-convert-hook]) (parameterize ([pretty-print-show-inexactness (stepper:show-inexactness?)]
[current-print-convert-hook stepper-print-convert-hook])
(set-print-settings (set-print-settings
language-level language-level
settings settings
(lambda () (lambda ()
(simple-module-based-language-convert-value (simple-module-based-language-convert-value
val val
(drscheme:language:simple-settings-printing-style settings) settings)))))
(drscheme:language:simple-settings-show-sharing settings))))))
(super-instantiate ()))))) (super-instantiate ())))))
@ -65,82 +71,82 @@
;; the stepper's frame: ;; the stepper's frame:
(define stepper-frame% (define stepper-frame%
(class (drscheme:frame:basics-mixin (class (drscheme:frame:basics-mixin
(frame:frame:standard-menus-mixin frame:frame:basic%)) (frame:frame:standard-menus-mixin frame:frame:basic%))
(init-field drscheme-frame) (init-field drscheme-frame)
;; PRINTING-PROC ;; PRINTING-PROC
;; I frankly don't think that printing (i.e., to a printer) works ;; I frankly don't think that printing (i.e., to a printer) works
;; correctly. 2005-07-01, JBC ;; correctly. 2005-07-01, JBC
(public set-printing-proc) (public set-printing-proc)
(define (set-printing-proc proc) (define (set-printing-proc proc)
(set! printing-proc proc)) (set! printing-proc proc))
(define (printing-proc item evt) (define (printing-proc item evt)
(message-box "error?" "shouldn't be called")) (message-box "error?" "shouldn't be called"))
(define/private (file-menu:print a b) (printing-proc a b)) (define/private (file-menu:print a b) (printing-proc a b))
;; MENUS ;; MENUS
(define/override (edit-menu:between-find-and-preferences edit-menu) (define/override (edit-menu:between-find-and-preferences edit-menu)
(void)) (void))
(define/override (edit-menu:between-select-all-and-find edit-menu) (define/override (edit-menu:between-select-all-and-find edit-menu)
(void)) (void))
(define/override (file-menu:between-save-as-and-print file-menu) (define/override (file-menu:between-save-as-and-print file-menu)
(void)) (void))
;; CUSTODIANS ;; CUSTODIANS
;; The custodian is used to halt the stepped computation when the ;; The custodian is used to halt the stepped computation when the
;; stepper window closes. The custodian is captured when the stepped ;; stepper window closes. The custodian is captured when the stepped
;; computation starts. ;; computation starts.
(define custodian #f) (define custodian #f)
(define/public (set-custodian! cust) (define/public (set-custodian! cust)
(set! custodian cust)) (set! custodian cust))
(define/augment (on-close) (define/augment (on-close)
(when custodian (when custodian
(custodian-shutdown-all custodian)) (custodian-shutdown-all custodian))
(send drscheme-frame on-stepper-close) (send drscheme-frame on-stepper-close)
(inner (void) on-close)) (inner (void) on-close))
;; WARNING BOXES: ;; WARNING BOXES:
(define program-changed-warning-str (define program-changed-warning-str
(string-constant stepper-program-has-changed)) (string-constant stepper-program-has-changed))
(define window-closed-warning-str (define window-closed-warning-str
(string-constant stepper-program-window-closed)) (string-constant stepper-program-window-closed))
(define warning-message-visible-already #f) (define warning-message-visible-already #f)
(define/private (add-warning-message warning-str) (define/private (add-warning-message warning-str)
(let ([warning-msg (new x:stepper-warning% (let ([warning-msg (new x:stepper-warning%
[warning-str warning-str] [warning-str warning-str]
[parent (get-area-container)])]) [parent (get-area-container)])])
(send (get-area-container) (send (get-area-container)
change-children change-children
(if warning-message-visible-already (if warning-message-visible-already
(lambda (l) (lambda (l)
(list (car l) warning-msg (caddr l))) (list (car l) warning-msg (caddr l)))
(lambda (l) (lambda (l)
(list (car l) warning-msg (cadr l))))) (list (car l) warning-msg (cadr l)))))
(set! warning-message-visible-already #t))) (set! warning-message-visible-already #t)))
(inherit get-area-container) (inherit get-area-container)
(define program-change-already-warned? #f) (define program-change-already-warned? #f)
(define/public (original-program-changed) (define/public (original-program-changed)
(unless program-change-already-warned? (unless program-change-already-warned?
(set! program-change-already-warned? #t) (set! program-change-already-warned? #t)
(add-warning-message program-changed-warning-str))) (add-warning-message program-changed-warning-str)))
(define/public (original-program-gone) (define/public (original-program-gone)
(add-warning-message window-closed-warning-str)) (add-warning-message window-closed-warning-str))
(super-new [label "Stepper"] [parent #f] (super-new [label "Stepper"] [parent #f]
[width stepper-initial-width] [width stepper-initial-width]
[height stepper-initial-height]))) [height stepper-initial-height])))
;; stepper-unit-frame<%> : the interface that the extended drscheme frame ;; stepper-unit-frame<%> : the interface that the extended drscheme frame
@ -314,44 +320,46 @@
;; COPIED FROM drscheme/private/language.ss ;; COPIED FROM drscheme/private/language.ss
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
(define (simple-module-based-language-convert-value value style show-sharing?) (define (simple-module-based-language-convert-value value settings)
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) (case (drscheme:language:simple-settings-printing-style settings)
(if (or (is-a? expr snip%)
;; FIXME: internal in language.ss (to-snip-value? expr)
)
expr
(sh expr basic-convert sub-convert)))
;; mflatt: MINOR HACK - work around temporary
;; print-convert problems
(define (stepper-print-convert v)
(or (and (procedure? v) (object-name v))
(print-convert v)))
(case style
[(write) value] [(write) value]
[(current-print) value]
[(constructor) [(constructor)
(parameterize (parameterize
([constructor-style-printing #t] ([constructor-style-printing #t]
[show-sharing show-sharing?] [show-sharing (drscheme:language:simple-settings-show-sharing settings)]
[current-print-convert-hook [current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))]) (leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))] (stepper-print-convert value))]
[(quasiquote) [(quasiquote)
(parameterize (parameterize
([constructor-style-printing #f] ([constructor-style-printing #f]
[show-sharing show-sharing?] [show-sharing (drscheme:language:simple-settings-show-sharing settings)]
[current-print-convert-hook [current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))]) (leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))] (stepper-print-convert value))]
[else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")]))
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
(if (or (is-a? expr snip%)
;; FIXME: internal in language.ss (to-snip-value? expr)
)
expr
(sh expr basic-convert sub-convert)))
;; mflatt: MINOR HACK - work around temporary
;; print-convert problems
(define (stepper-print-convert v)
(or (and (procedure? v) (object-name v))
(print-convert v)))
;; set-print-settings ; settings ( -> TST) -> TST ;; set-print-settings ; settings ( -> TST) -> TST
(define (set-print-settings language simple-settings thunk) (define (set-print-settings language simple-settings thunk)
(if (method-in-interface? 'set-printing-parameters (object-interface language)) (if (method-in-interface? 'set-printing-parameters (object-interface language))
(send language set-printing-parameters simple-settings thunk) (send language set-printing-parameters simple-settings thunk)
;; assume that the current print-convert context is fine ;; assume that the current print-convert context is fine
;; (error 'stepper-tool "language object does not contain set-printing-parameters method") ;; (error 'stepper-tool "language object does not contain set-printing-parameters method")
;; 2009-09-11, JBC : Gee Whiz, why the heck is it okay to assume that !?
(thunk))) (thunk)))
;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC)

72
collects/stepper/view-controller.ss
View File

@ -11,7 +11,9 @@
(prefix-in x: "private/mred-extensions.ss") (prefix-in x: "private/mred-extensions.ss")
"private/shared.ss" "private/shared.ss"
"private/model-settings.ss" "private/model-settings.ss"
"xml-sig.ss") "xml-sig.ss"
(only-in scheme/pretty pretty-print-show-inexactness))
(import drscheme:tool^ xml^ stepper-frame^) (import drscheme:tool^ xml^ stepper-frame^)
(export view-controller^) (export view-controller^)
@ -21,25 +23,18 @@
(define (definitions-text->settings definitions-text) (define (definitions-text->settings definitions-text)
(send definitions-text get-next-settings)) (send definitions-text get-next-settings))
(define (settings->language-level settings)
(drscheme:language-configuration:language-settings-language settings))
;; the stored representation of a step ;; the stored representation of a step
(define-struct step (text kind posns) #:transparent) (define-struct step (text kind posns) #:transparent)
(define (go drscheme-frame program-expander selection-start selection-end) (define (go drscheme-frame program-expander selection-start selection-end)
;; get the language-level name: ;; get the language-level:
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text)))
(define language-level (define language-level (drscheme:language-configuration:language-settings-language language-settings))
(settings->language-level language-settings)) (define simple-settings (drscheme:language-configuration:language-settings-settings language-settings))
;; VALUE CONVERSION CODE: ;; VALUE CONVERSION CODE:
(define simple-settings
(drscheme:language-configuration:language-settings-settings
language-settings))
;; render-to-string : TST -> string ;; render-to-string : TST -> string
(define (render-to-string val) (define (render-to-string val)
(let ([string-port (open-output-string)]) (let ([string-port (open-output-string)])
@ -99,8 +94,8 @@
[else [else
;; nope, keep running: ;; nope, keep running:
(begin (if (finished-stepping-step? new-step) (begin (if (finished-stepping-step? new-step)
(begin (message-box "Ran out of steps" (begin (message-box (string-constant stepper-no-such-step/title)
"Reached the end of evaluation before finding the kind of step you were looking for.") (string-constant stepper-out-of-steps))
(update-view/existing (- (length view-history) 1))) (update-view/existing (- (length view-history) 1)))
(semaphore-post semaphore)))])])]))) (semaphore-post semaphore)))])])])))
(semaphore-wait new-semaphore))) (semaphore-wait new-semaphore)))
@ -210,8 +205,8 @@
(wait-for-it))] (wait-for-it))]
[#f (wait-for-it)])))] [#f (wait-for-it)])))]
['nomatch/seen-final ['nomatch/seen-final
(message-box "Step Not Found" (message-box (string-constant stepper-no-such-step/title)
"Couldn't find a step matching that criterion.") (string-constant stepper-no-such-step))
(update-view/existing (- (length view-history) 1))])) (update-view/existing (- (length view-history) 1))]))
;; prior-of-specified-kind: if the desired step is already in the list, display ;; prior-of-specified-kind: if the desired step is already in the list, display
@ -222,8 +217,8 @@
(if found-step (if found-step
(update-view/existing found-step) (update-view/existing found-step)
(begin (begin
(message-box "Step Not Found" (message-box (string-constant stepper-no-such-step/title)
"Couldn't find an earlier step matching that criterion.") (string-constant stepper-no-such-step/earlier))
(update-view/existing 0))))) (update-view/existing 0)))))
;; BUTTON/CHOICE BOX PROCEDURES ;; BUTTON/CHOICE BOX PROCEDURES
@ -275,15 +270,15 @@
(define (add-button name fun) (define (add-button name fun)
(make-object button% name button-panel (lambda (_1 _2) (fun)))) (make-object button% name button-panel (lambda (_1 _2) (fun))))
(define (add-choice-box name fun) (define (add-choice-box name fun)
(new choice% [label "Jump..."] (new choice% [label name]
[choices (map first pulldown-choices)] [choices (map first pulldown-choices)]
[parent button-panel] [parent button-panel]
[callback fun])) [callback fun]))
(define pulldown-choices (define pulldown-choices
`(("to beginning" ,jump-to-beginning) `((,(string-constant stepper-jump-to-beginning) ,jump-to-beginning)
("to end" ,jump-to-end) (,(string-constant stepper-jump-to-end) ,jump-to-end)
("to beginning of selected" ,jump-to-selected))) (,(string-constant stepper-jump-to-selected) ,jump-to-selected)))
(define previous-application-button (add-button (string-constant stepper-previous-application) previous-application)) (define previous-application-button (add-button (string-constant stepper-previous-application) previous-application))
(define previous-button (add-button (string-constant stepper-previous) previous)) (define previous-button (add-button (string-constant stepper-previous) previous))
@ -347,18 +342,29 @@
;; on-screen. Runs on the user thread. ;; on-screen. Runs on the user thread.
;; : (step-result -> void) ;; : (step-result -> void)
(define (receive-result result) (define (receive-result result)
(match-let* ;; let's make sure this works:
([(list step-text step-kind posns) (parameterize ([pretty-print-show-inexactness #t])
(match result (match-let*
[(struct before-after-result (pre-exps post-exps kind pre-src post-src)) ([(list step-text step-kind posns)
(list (new x:stepper-text% [left-side pre-exps] [right-side post-exps]) kind (list pre-src post-src))] (match result
[(struct before-error-result (pre-exps err-msg pre-src)) [(struct before-after-result (pre-exps post-exps kind pre-src post-src))
(list (new x:stepper-text% [left-side pre-exps] [right-side err-msg]) 'finished-or-error (list pre-src))] (list (new x:stepper-text%
[(struct error-result (err-msg)) [left-side pre-exps]
(list (new x:stepper-text% [left-side null] [right-side err-msg]) 'finished-or-error (list))] [right-side post-exps]
[(struct finished-stepping ()) ;; get this from the language level
(list x:finished-text 'finished-or-error (list))])]) [show-inexactness? (send language-level stepper:show-inexactness?)])
(hand-off-and-block step-text step-kind posns))) kind (list pre-src post-src))]
[(struct before-error-result (pre-exps err-msg pre-src))
(list (new x:stepper-text%
[left-side pre-exps]
[right-side err-msg]
[show-inexactness? (send language-level stepper:show-inexactness?)])
'finished-or-error (list pre-src))]
[(struct error-result (err-msg))
(list (new x:stepper-text% [left-side null] [right-side err-msg]) 'finished-or-error (list))]
[(struct finished-stepping ())
(list x:finished-text 'finished-or-error (list))])])
(hand-off-and-block step-text step-kind posns))))
;; program-expander-prime : wrap the program-expander for a couple of reasons: ;; program-expander-prime : wrap the program-expander for a couple of reasons:
;; 1) we need to capture the custodian as the thread starts up: ;; 1) we need to capture the custodian as the thread starts up: