fixed #i printing
svn: r15993
This commit is contained in:
John Clements
parent
4510c0339f
commit
7bb15bbbeb
|
|
@ -1,7 +1,8 @@
|
|||
(module mred-extensions mzscheme
|
||||
#lang scheme
|
||||
|
||||
(require mzlib/class
|
||||
mred
|
||||
(prefix f: framework)
|
||||
(prefix-in f: framework)
|
||||
mzlib/pretty
|
||||
#;"testing-shared.ss"
|
||||
"shared.ss")
|
||||
|
|
@ -38,7 +39,7 @@
|
|||
(error 'red-arrow-bitmap "unable to load red-arrow bitmap"))
|
||||
|
||||
(define vertical-separator-snip-class%
|
||||
(class snip-class% ()
|
||||
(class snip-class%
|
||||
(override read)
|
||||
|
||||
(define (read s)
|
||||
|
|
@ -59,7 +60,7 @@
|
|||
(send (get-the-snip-class-list) add vertical-separator-snipclass)
|
||||
|
||||
(define vertical-separator-snip%
|
||||
(class snip% ()
|
||||
(class snip%
|
||||
(inherit get-style set-snipclass set-flags get-flags get-admin)
|
||||
(public set-height!)
|
||||
(override write copy get-extent draw)
|
||||
|
|
@ -103,7 +104,7 @@
|
|||
;;;; end of vertical snip-stuff
|
||||
|
||||
(define stepper-editor-snip%
|
||||
(class editor-snip% ()
|
||||
(class editor-snip%
|
||||
(inherit get-editor set-min-width set-max-width)
|
||||
(public*
|
||||
[set-new-width
|
||||
|
|
@ -131,9 +132,9 @@
|
|||
; there are four of them (* NB: now only two! 2005-08) in the stepper window.
|
||||
|
||||
(define stepper-sub-text%
|
||||
(class f:text:standard-style-list% ()
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field exps highlight-color)
|
||||
(init-field exps highlight-color show-inexactness?)
|
||||
|
||||
(inherit insert get-style-list set-style-list change-style highlight-range last-position lock erase
|
||||
begin-edit-sequence end-edit-sequence get-start-position select-all clear)
|
||||
|
|
@ -147,7 +148,7 @@
|
|||
(reformat-sexp width)
|
||||
(end-edit-sequence)))])
|
||||
|
||||
(define highlight-table (make-hash-table 'weak))
|
||||
(define highlight-table (make-weak-hash))
|
||||
|
||||
(define stripped-exps
|
||||
(map (lambda (exp) (strip-to-sexp exp highlight-table)) exps))
|
||||
|
|
@ -174,14 +175,15 @@
|
|||
(define text-port (open-output-text-editor this))
|
||||
|
||||
(parameterize
|
||||
([pretty-print-columns pretty-printed-width]
|
||||
([pretty-print-show-inexactness show-inexactness?]
|
||||
[pretty-print-columns pretty-printed-width]
|
||||
|
||||
; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook
|
||||
[pretty-print-size-hook
|
||||
(lambda (value display? port)
|
||||
(when (not highlight-table)
|
||||
(fprintf (current-error-port) "hey! the highlight-table doesn't exist! (1)"))
|
||||
(let ([looked-up (hash-table-get highlight-table value (lambda () #f))])
|
||||
(let ([looked-up (hash-ref highlight-table value (lambda () #f))])
|
||||
(cond
|
||||
[(is-a? value snip%)
|
||||
;; Calculate the effective width of the snip, so that
|
||||
|
|
@ -204,12 +206,15 @@
|
|||
(when (not highlight-table)
|
||||
(fprintf (current-error-port) "hey! the highlight-table doesn't exist! (2)"))
|
||||
(let ([to-display (cond
|
||||
[(hash-table-get highlight-table value (lambda () #f)) => car]
|
||||
[(hash-ref highlight-table value (lambda () #f)) => car]
|
||||
[else value])])
|
||||
(cond
|
||||
[(is-a? to-display snip%)
|
||||
(write-special (send to-display copy) port) (set-last-style)]
|
||||
[else
|
||||
;; there's already code somewhere else to handle this; this seems like a bit of a hack.
|
||||
(when (and (number? to-display) (inexact? to-display) (pretty-print-show-inexactness))
|
||||
(write-string "#i" port))
|
||||
(write-string (format "~s" to-display) port)])))]
|
||||
[pretty-print-print-line
|
||||
(lambda (number port old-length dest-columns)
|
||||
|
|
@ -220,13 +225,13 @@
|
|||
(lambda (value p)
|
||||
(when (not highlight-table)
|
||||
(fprintf (current-error-port) "hey! the highlight-table doesn't exist! (3)"))
|
||||
(when (hash-table-get highlight-table value (lambda () #f))
|
||||
(when (hash-ref highlight-table value (lambda () #f))
|
||||
(set! highlight-begin (get-start-position))))]
|
||||
[pretty-print-post-print-hook
|
||||
(lambda (value p)
|
||||
(when (not highlight-table)
|
||||
(fprintf (current-error-port) "hey! the highlight-table doesn't exist! (4)"))
|
||||
(when (hash-table-get highlight-table value (lambda () #f))
|
||||
(when (hash-ref highlight-table value (lambda () #f))
|
||||
(let ([highlight-end (get-start-position)])
|
||||
(unless highlight-begin
|
||||
(error 'format-whole-step "no highlight-begin to match highlight-end"))
|
||||
|
|
@ -236,7 +241,8 @@
|
|||
(set! highlight-begin #f))))]
|
||||
;; mflatt: MAJOR HACK - this setting needs to come from the language
|
||||
;; somehow
|
||||
[read-case-sensitive #t])
|
||||
[read-case-sensitive #t]
|
||||
)
|
||||
(pretty-print sexp text-port)))
|
||||
|
||||
(define/public (format-whole-step)
|
||||
|
|
@ -258,23 +264,21 @@
|
|||
(super-instantiate ())))
|
||||
|
||||
|
||||
; ;; ;
|
||||
; ; ; ; ; ; ;
|
||||
;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;; ; ;; ; ;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ;
|
||||
; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ;; ;; ; ; ;; ; ; ; ; ; ; ;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
||||
;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ;;;;; ; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
||||
; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;;;; ; ; ;;; ; ;; ;;;; ; ; ;;; ;;
|
||||
; ;
|
||||
; ;
|
||||
; ;;; ;;;; ;;; ; ;;; ; ;;; ;;; ; ;; ;;; ; ; ; ;;; ;;; ; ;; ; ;; ;;; ; ;; ;;;; ;;; ; ; ;;;;; ; ;
|
||||
; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ;; ; ; ; ;; ;; ; ; ;; ; ; ; ; ; ; ;; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
||||
; ;; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ; ; ;;;;; ;;;;; ; ; ; ; ; ;;;;; ; ;;;;; ;; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
||||
; ; ; ; ;; ; ;; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;; ; ; ;;; ;;;; ; ; ;;; ; ;; ;;;; ; ; ;;; ;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
|
||||
; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots.
|
||||
; it is used for error messages.
|
||||
|
||||
(define stepper-sub-error-text%
|
||||
(class f:text:standard-style-list% ()
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field error-msg)
|
||||
|
||||
|
|
@ -308,7 +312,7 @@
|
|||
;; the enclosed editor.
|
||||
|
||||
(define stepper-canvas%
|
||||
(class editor-canvas% ()
|
||||
(class editor-canvas%
|
||||
(inherit get-editor)
|
||||
(override*
|
||||
[on-size
|
||||
|
|
@ -338,9 +342,9 @@
|
|||
;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> )
|
||||
|
||||
(define stepper-text%
|
||||
(class f:text:standard-style-list% ()
|
||||
(class f:text:standard-style-list%
|
||||
|
||||
(init-field left-side right-side)
|
||||
(init-field left-side right-side show-inexactness?)
|
||||
|
||||
(inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap
|
||||
begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list
|
||||
|
|
@ -406,7 +410,7 @@
|
|||
(cond [(string? error-or-exps)
|
||||
(make-object stepper-sub-error-text% error-or-exps)]
|
||||
[else
|
||||
(make-object stepper-sub-text% error-or-exps highlight-color)])))
|
||||
(make-object stepper-sub-text% error-or-exps highlight-color show-inexactness?)])))
|
||||
|
||||
(setup-editor-snip before-snip left-side redex-highlight-color)
|
||||
(setup-editor-snip after-snip right-side reduct-highlight-color)
|
||||
|
|
@ -417,7 +421,7 @@
|
|||
(lock #t)))
|
||||
|
||||
(define finished-text
|
||||
(instantiate (class text% ()
|
||||
(instantiate (class text%
|
||||
(define/public (reset-width arg)
|
||||
(void))
|
||||
|
||||
|
|
@ -502,10 +506,10 @@
|
|||
(stepper-syntax-property stx 'stepper-highlight))
|
||||
(if (pair? it)
|
||||
(begin
|
||||
(hash-table-put! highlight-table it 'non-confusable)
|
||||
(hash-set! highlight-table it 'non-confusable)
|
||||
it)
|
||||
(let ([new-sym (gensym "-placeholder")])
|
||||
(hash-table-put! highlight-table new-sym (list it))
|
||||
(hash-set! highlight-table new-sym (list it))
|
||||
new-sym))
|
||||
it)])
|
||||
it))
|
||||
|
|
@ -544,14 +548,16 @@
|
|||
#;(define a
|
||||
(stepper-text-test (build-stx-with-highlight `((* 13 (hilite (* 15 16)))))
|
||||
(build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+ (hilite 13) (hilite #f)) 13
|
||||
298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))))
|
||||
298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))
|
||||
#t))
|
||||
|
||||
;; test out scroll bars
|
||||
#;(stepper-text-test (build-stx-with-highlight `(1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8))
|
||||
(build-stx-with-highlight `(free!)))
|
||||
(build-stx-with-highlight `(free!))
|
||||
#t)
|
||||
|
||||
#;(stepper-text-test `() "This is an error message" )
|
||||
#;(stepper-text-test `() "This is an error message" #t)
|
||||
|
||||
#;(stepper-text-test "This is another error message" `(poomp) #t)
|
||||
|
||||
#;(stepper-text-test "This is another error message" `(poomp))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ())))))
|
||||
|
||||
|
|
@ -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^)
|
||||
|
|
@ -21,25 +23,18 @@
|
|||
(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)
|
||||
;; 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]) kind (list 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]) 'finished-or-error (list 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)))
|
||||
(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