fixed #i printing
svn: r15993
This commit is contained in:
John Clements
parent
4510c0339f
commit
7bb15bbbeb
File diff suppressed because it is too large
Load Diff
|
|
@ -11,6 +11,7 @@
|
|||
(prefix-in x: "private/mred-extensions.ss")
|
||||
"private/shared.ss"
|
||||
lang/stepper-language-interface
|
||||
scheme/pretty
|
||||
"xml-sig.ss")
|
||||
|
||||
(import drscheme:tool^ xml^ view-controller^)
|
||||
|
|
@ -18,7 +19,6 @@
|
|||
|
||||
;; tool magic here:
|
||||
(define (phase1)
|
||||
|
||||
;; experiment with extending the language... parameter-like fields for stepper parameters
|
||||
(drscheme:language:extend-language-interface
|
||||
stepper-language<%>
|
||||
|
|
@ -26,21 +26,27 @@
|
|||
(class* superclass (stepper-language<%>)
|
||||
(public stepper:supported?)
|
||||
(define (stepper:supported?) #f)
|
||||
|
||||
(public stepper:enable-let-lifting?)
|
||||
(define (stepper:enable-let-lifting?) #f)
|
||||
|
||||
(public stepper:show-lambdas-as-lambdas?)
|
||||
(define (stepper:show-lambdas-as-lambdas?) #t)
|
||||
|
||||
(public stepper:show-inexactness?)
|
||||
(define (stepper:show-inexactness?) #t)
|
||||
|
||||
(public stepper:render-to-sexp)
|
||||
(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
|
||||
language-level
|
||||
settings
|
||||
(lambda ()
|
||||
(simple-module-based-language-convert-value
|
||||
val
|
||||
(drscheme:language:simple-settings-printing-style settings)
|
||||
(drscheme:language:simple-settings-show-sharing settings))))))
|
||||
settings)))))
|
||||
|
||||
(super-instantiate ())))))
|
||||
|
||||
|
|
@ -65,82 +71,82 @@
|
|||
|
||||
;; the stepper's frame:
|
||||
|
||||
(define stepper-frame%
|
||||
(class (drscheme:frame:basics-mixin
|
||||
(frame:frame:standard-menus-mixin frame:frame:basic%))
|
||||
|
||||
(init-field drscheme-frame)
|
||||
|
||||
;; PRINTING-PROC
|
||||
;; I frankly don't think that printing (i.e., to a printer) works
|
||||
;; correctly. 2005-07-01, JBC
|
||||
(public set-printing-proc)
|
||||
|
||||
(define (set-printing-proc proc)
|
||||
(set! printing-proc proc))
|
||||
|
||||
(define (printing-proc item evt)
|
||||
(message-box "error?" "shouldn't be called"))
|
||||
|
||||
(define/private (file-menu:print a b) (printing-proc a b))
|
||||
|
||||
;; MENUS
|
||||
|
||||
(define/override (edit-menu:between-find-and-preferences edit-menu)
|
||||
(void))
|
||||
(define/override (edit-menu:between-select-all-and-find edit-menu)
|
||||
(void))
|
||||
(define/override (file-menu:between-save-as-and-print file-menu)
|
||||
(void))
|
||||
|
||||
;; CUSTODIANS
|
||||
;; The custodian is used to halt the stepped computation when the
|
||||
;; stepper window closes. The custodian is captured when the stepped
|
||||
;; computation starts.
|
||||
|
||||
(define custodian #f)
|
||||
(define/public (set-custodian! cust)
|
||||
(set! custodian cust))
|
||||
(define/augment (on-close)
|
||||
(when custodian
|
||||
(custodian-shutdown-all custodian))
|
||||
(send drscheme-frame on-stepper-close)
|
||||
(inner (void) on-close))
|
||||
|
||||
;; WARNING BOXES:
|
||||
|
||||
(define program-changed-warning-str
|
||||
(string-constant stepper-program-has-changed))
|
||||
(define window-closed-warning-str
|
||||
(string-constant stepper-program-window-closed))
|
||||
|
||||
(define warning-message-visible-already #f)
|
||||
(define/private (add-warning-message warning-str)
|
||||
(let ([warning-msg (new x:stepper-warning%
|
||||
[warning-str warning-str]
|
||||
[parent (get-area-container)])])
|
||||
(send (get-area-container)
|
||||
change-children
|
||||
(if warning-message-visible-already
|
||||
(lambda (l)
|
||||
(list (car l) warning-msg (caddr l)))
|
||||
(lambda (l)
|
||||
(list (car l) warning-msg (cadr l)))))
|
||||
(set! warning-message-visible-already #t)))
|
||||
|
||||
(inherit get-area-container)
|
||||
(define program-change-already-warned? #f)
|
||||
(define/public (original-program-changed)
|
||||
(unless program-change-already-warned?
|
||||
(set! program-change-already-warned? #t)
|
||||
(add-warning-message program-changed-warning-str)))
|
||||
|
||||
(define/public (original-program-gone)
|
||||
(add-warning-message window-closed-warning-str))
|
||||
|
||||
(super-new [label "Stepper"] [parent #f]
|
||||
[width stepper-initial-width]
|
||||
[height stepper-initial-height])))
|
||||
(define stepper-frame%
|
||||
(class (drscheme:frame:basics-mixin
|
||||
(frame:frame:standard-menus-mixin frame:frame:basic%))
|
||||
|
||||
(init-field drscheme-frame)
|
||||
|
||||
;; PRINTING-PROC
|
||||
;; I frankly don't think that printing (i.e., to a printer) works
|
||||
;; correctly. 2005-07-01, JBC
|
||||
(public set-printing-proc)
|
||||
|
||||
(define (set-printing-proc proc)
|
||||
(set! printing-proc proc))
|
||||
|
||||
(define (printing-proc item evt)
|
||||
(message-box "error?" "shouldn't be called"))
|
||||
|
||||
(define/private (file-menu:print a b) (printing-proc a b))
|
||||
|
||||
;; MENUS
|
||||
|
||||
(define/override (edit-menu:between-find-and-preferences edit-menu)
|
||||
(void))
|
||||
(define/override (edit-menu:between-select-all-and-find edit-menu)
|
||||
(void))
|
||||
(define/override (file-menu:between-save-as-and-print file-menu)
|
||||
(void))
|
||||
|
||||
;; CUSTODIANS
|
||||
;; The custodian is used to halt the stepped computation when the
|
||||
;; stepper window closes. The custodian is captured when the stepped
|
||||
;; computation starts.
|
||||
|
||||
(define custodian #f)
|
||||
(define/public (set-custodian! cust)
|
||||
(set! custodian cust))
|
||||
(define/augment (on-close)
|
||||
(when custodian
|
||||
(custodian-shutdown-all custodian))
|
||||
(send drscheme-frame on-stepper-close)
|
||||
(inner (void) on-close))
|
||||
|
||||
;; WARNING BOXES:
|
||||
|
||||
(define program-changed-warning-str
|
||||
(string-constant stepper-program-has-changed))
|
||||
(define window-closed-warning-str
|
||||
(string-constant stepper-program-window-closed))
|
||||
|
||||
(define warning-message-visible-already #f)
|
||||
(define/private (add-warning-message warning-str)
|
||||
(let ([warning-msg (new x:stepper-warning%
|
||||
[warning-str warning-str]
|
||||
[parent (get-area-container)])])
|
||||
(send (get-area-container)
|
||||
change-children
|
||||
(if warning-message-visible-already
|
||||
(lambda (l)
|
||||
(list (car l) warning-msg (caddr l)))
|
||||
(lambda (l)
|
||||
(list (car l) warning-msg (cadr l)))))
|
||||
(set! warning-message-visible-already #t)))
|
||||
|
||||
(inherit get-area-container)
|
||||
(define program-change-already-warned? #f)
|
||||
(define/public (original-program-changed)
|
||||
(unless program-change-already-warned?
|
||||
(set! program-change-already-warned? #t)
|
||||
(add-warning-message program-changed-warning-str)))
|
||||
|
||||
(define/public (original-program-gone)
|
||||
(add-warning-message window-closed-warning-str))
|
||||
|
||||
(super-new [label "Stepper"] [parent #f]
|
||||
[width stepper-initial-width]
|
||||
[height stepper-initial-height])))
|
||||
|
||||
|
||||
;; stepper-unit-frame<%> : the interface that the extended drscheme frame
|
||||
|
|
@ -314,44 +320,46 @@
|
|||
|
||||
;; COPIED FROM drscheme/private/language.ss
|
||||
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
|
||||
(define (simple-module-based-language-convert-value value style show-sharing?)
|
||||
(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)))
|
||||
|
||||
(case style
|
||||
(define (simple-module-based-language-convert-value value settings)
|
||||
(case (drscheme:language:simple-settings-printing-style settings)
|
||||
[(write) value]
|
||||
[(current-print) value]
|
||||
[(constructor)
|
||||
(parameterize
|
||||
([constructor-style-printing #t]
|
||||
[show-sharing show-sharing?]
|
||||
[show-sharing (drscheme:language:simple-settings-show-sharing settings)]
|
||||
[current-print-convert-hook
|
||||
(leave-snips-alone-hook (current-print-convert-hook))])
|
||||
(stepper-print-convert value))]
|
||||
[(quasiquote)
|
||||
(parameterize
|
||||
([constructor-style-printing #f]
|
||||
[show-sharing show-sharing?]
|
||||
[show-sharing (drscheme:language:simple-settings-show-sharing settings)]
|
||||
[current-print-convert-hook
|
||||
(leave-snips-alone-hook (current-print-convert-hook))])
|
||||
(stepper-print-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
|
||||
(define (set-print-settings language simple-settings thunk)
|
||||
(if (method-in-interface? 'set-printing-parameters (object-interface language))
|
||||
(send language set-printing-parameters simple-settings thunk)
|
||||
;; assume that the current print-convert context is fine
|
||||
;; (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)))
|
||||
|
||||
;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC)
|
||||
|
|
|
|||
|
|
@ -11,7 +11,9 @@
|
|||
(prefix-in x: "private/mred-extensions.ss")
|
||||
"private/shared.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^)
|
||||
(export view-controller^)
|
||||
|
|
@ -20,26 +22,19 @@
|
|||
|
||||
(define (definitions-text->settings definitions-text)
|
||||
(send definitions-text get-next-settings))
|
||||
|
||||
(define (settings->language-level settings)
|
||||
(drscheme:language-configuration:language-settings-language settings))
|
||||
|
||||
;; the stored representation of a step
|
||||
(define-struct step (text kind posns) #:transparent)
|
||||
|
||||
(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-level
|
||||
(settings->language-level language-settings))
|
||||
(define language-level (drscheme:language-configuration:language-settings-language language-settings))
|
||||
(define simple-settings (drscheme:language-configuration:language-settings-settings language-settings))
|
||||
|
||||
;; VALUE CONVERSION CODE:
|
||||
|
||||
(define simple-settings
|
||||
(drscheme:language-configuration:language-settings-settings
|
||||
language-settings))
|
||||
|
||||
;; render-to-string : TST -> string
|
||||
(define (render-to-string val)
|
||||
(let ([string-port (open-output-string)])
|
||||
|
|
@ -99,8 +94,8 @@
|
|||
[else
|
||||
;; nope, keep running:
|
||||
(begin (if (finished-stepping-step? new-step)
|
||||
(begin (message-box "Ran out of steps"
|
||||
"Reached the end of evaluation before finding the kind of step you were looking for.")
|
||||
(begin (message-box (string-constant stepper-no-such-step/title)
|
||||
(string-constant stepper-out-of-steps))
|
||||
(update-view/existing (- (length view-history) 1)))
|
||||
(semaphore-post semaphore)))])])])))
|
||||
(semaphore-wait new-semaphore)))
|
||||
|
|
@ -210,8 +205,8 @@
|
|||
(wait-for-it))]
|
||||
[#f (wait-for-it)])))]
|
||||
['nomatch/seen-final
|
||||
(message-box "Step Not Found"
|
||||
"Couldn't find a step matching that criterion.")
|
||||
(message-box (string-constant stepper-no-such-step/title)
|
||||
(string-constant stepper-no-such-step))
|
||||
(update-view/existing (- (length view-history) 1))]))
|
||||
|
||||
;; prior-of-specified-kind: if the desired step is already in the list, display
|
||||
|
|
@ -222,8 +217,8 @@
|
|||
(if found-step
|
||||
(update-view/existing found-step)
|
||||
(begin
|
||||
(message-box "Step Not Found"
|
||||
"Couldn't find an earlier step matching that criterion.")
|
||||
(message-box (string-constant stepper-no-such-step/title)
|
||||
(string-constant stepper-no-such-step/earlier))
|
||||
(update-view/existing 0)))))
|
||||
|
||||
;; BUTTON/CHOICE BOX PROCEDURES
|
||||
|
|
@ -275,15 +270,15 @@
|
|||
(define (add-button name fun)
|
||||
(make-object button% name button-panel (lambda (_1 _2) (fun))))
|
||||
(define (add-choice-box name fun)
|
||||
(new choice% [label "Jump..."]
|
||||
(new choice% [label name]
|
||||
[choices (map first pulldown-choices)]
|
||||
[parent button-panel]
|
||||
[callback fun]))
|
||||
|
||||
(define pulldown-choices
|
||||
`(("to beginning" ,jump-to-beginning)
|
||||
("to end" ,jump-to-end)
|
||||
("to beginning of selected" ,jump-to-selected)))
|
||||
`((,(string-constant stepper-jump-to-beginning) ,jump-to-beginning)
|
||||
(,(string-constant stepper-jump-to-end) ,jump-to-end)
|
||||
(,(string-constant stepper-jump-to-selected) ,jump-to-selected)))
|
||||
|
||||
(define previous-application-button (add-button (string-constant stepper-previous-application) previous-application))
|
||||
(define previous-button (add-button (string-constant stepper-previous) previous))
|
||||
|
|
@ -347,18 +342,29 @@
|
|||
;; on-screen. Runs on the user thread.
|
||||
;; : (step-result -> void)
|
||||
(define (receive-result result)
|
||||
(match-let*
|
||||
([(list step-text step-kind posns)
|
||||
(match result
|
||||
[(struct before-after-result (pre-exps post-exps kind pre-src post-src))
|
||||
(list (new x:stepper-text% [left-side pre-exps] [right-side post-exps]) 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]) '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)))
|
||||
;; let's make sure this works:
|
||||
(parameterize ([pretty-print-show-inexactness #t])
|
||||
(match-let*
|
||||
([(list step-text step-kind posns)
|
||||
(match result
|
||||
[(struct before-after-result (pre-exps post-exps kind pre-src post-src))
|
||||
(list (new x:stepper-text%
|
||||
[left-side pre-exps]
|
||||
[right-side post-exps]
|
||||
;; get this from the language level
|
||||
[show-inexactness? (send language-level stepper:show-inexactness?)])
|
||||
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:
|
||||
;; 1) we need to capture the custodian as the thread starts up:
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user