diff --git a/htdp-lib/lang/htdp-langs.rkt b/htdp-lib/lang/htdp-langs.rkt index 6e2fcbac..0767079f 100644 --- a/htdp-lib/lang/htdp-langs.rkt +++ b/htdp-lib/lang/htdp-langs.rkt @@ -726,12 +726,37 @@ (define (stepper-settings-language %) (if (implementation? % stepper-language<%>) (class* % (stepper-language<%>) + (inherit get-abbreviate-cons-as-list + get-use-function-output-syntax? + get-output-function-instead-of-lambda?) (init-field stepper:supported) (init-field stepper:enable-let-lifting) (init-field stepper:show-lambdas-as-lambdas) (define/override (stepper:supported?) stepper:supported) (define/override (stepper:enable-let-lifting?) stepper:enable-let-lifting) (define/override (stepper:show-lambdas-as-lambdas?) stepper:show-lambdas-as-lambdas) + (define/override (stepper:pretty-print-hooks settings previous-size-hook previous-print-hook) + ;; avoid mutating the parameters in the current thread + ;; (the stepper will typically run in the same thread on subsequent invocations) + (thread-wait + (thread + (lambda () + (parameterize ((pretty-print-size-hook previous-size-hook) + (pretty-print-print-hook previous-print-hook)) + (configure/settings + (sl-runtime-settings (drscheme:language:simple-settings-printing-style settings) + (drscheme:language:simple-settings-fraction-style settings) + (drscheme:language:simple-settings-show-sharing settings) + (drscheme:language:simple-settings-insert-newlines settings) + (htdp-lang-settings-tracing? settings) + (htdp-lang-settings-true/false/empty-as-ids? settings) + (get-abbreviate-cons-as-list) + (get-use-function-output-syntax?) + (get-output-function-instead-of-lambda?))) + (values (pretty-print-size-hook) + (pretty-print-print-hook)))) + #:keep 'results))) + (super-new)) (class* % () (init stepper:supported) diff --git a/htdp-lib/lang/private/sl-stepper-button.rkt b/htdp-lib/lang/private/sl-stepper-button.rkt index 99e293fe..329e6e5b 100644 --- a/htdp-lib/lang/private/sl-stepper-button.rkt +++ b/htdp-lib/lang/private/sl-stepper-button.rkt @@ -49,8 +49,22 @@ (public stepper:show-consumed-and/or-clauses?) (define (stepper:show-consumed-and/or-clauses?) #t) + (public stepper:pretty-print-hooks) + (define (stepper:pretty-print-hooks settings previous-size-hook previous-print-hook) + ;; avoid mutating the parameters in the current thread + ;; (the stepper will typically run in the same thread on subsequent invocations) + (thread-wait + (thread + (lambda () + (parameterize ((pretty-print-size-hook previous-size-hook) + (pretty-print-print-hook previous-print-hook)) + (configure/settings settings) + (values (pretty-print-size-hook) + (pretty-print-print-hook)))) + #:keep 'results))) + (public stepper:render-to-sexp) - (define (stepper:render-to-sexp val settings language-level) + (define (stepper:render-to-sexp val language-level) (when (boolean? val) (log-stepper-debug "render-to-sexp got a boolean: ~v\n" val)) (or (and (procedure? val) @@ -63,6 +77,3 @@ (print val port))) (super-instantiate ()))) - - - diff --git a/htdp-lib/lang/stepper-language-interface.rkt b/htdp-lib/lang/stepper-language-interface.rkt index 92666384..6606990e 100644 --- a/htdp-lib/lang/stepper-language-interface.rkt +++ b/htdp-lib/lang/stepper-language-interface.rkt @@ -10,4 +10,7 @@ stepper:show-lambdas-as-lambdas? stepper:show-inexactness? stepper:show-consumed-and/or-clauses? + ; takes settings, previous -size-hook and -print-hook as arguments + ; returns the language's -size-hook, -print-hook + stepper:pretty-print-hooks stepper:render-to-sexp))) diff --git a/htdp-lib/stepper/private/mred-extensions.rkt b/htdp-lib/stepper/private/mred-extensions.rkt index 96714d6c..c43207de 100644 --- a/htdp-lib/stepper/private/mred-extensions.rkt +++ b/htdp-lib/stepper/private/mred-extensions.rkt @@ -7,6 +7,7 @@ images/compile-time string-constants pict + simple-tree-text-markup/data (for-syntax images/icons/control images/icons/style)) (provide @@ -137,7 +138,10 @@ (define stepper-sub-text% (class f:text:standard-style-list% - (init-field exps highlight-color show-inexactness? print-boolean-long-form?) + (init-field exps highlight-color + language-pretty-print-size-hook + language-pretty-print-print-hook + show-inexactness? print-boolean-long-form?) (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) @@ -178,8 +182,17 @@ (inherit get-dc) (define/private (format-sexp sexp) - (define text-port (open-output-text-editor this)) - + (define text-port + (open-output-text-editor this 'end + ; need to handle number-markup + (lambda (x) + (if (number-markup? x) + (f:number-snip:number->string/snip (number-markup-number x) + #:exact-prefix (number-markup-exact-prefix x) + #:inexact-prefix (number-markup-inexact-prefix x) + #:fraction-view (number-markup-fraction-view x)) + x)))) + (parameterize ([pretty-print-show-inexactness show-inexactness?] [pretty-print-columns pretty-printed-width] @@ -202,23 +215,31 @@ (let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")]) (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))] [(and looked-up (not (eq? looked-up 'non-confusable))) - (string-length (format "~s" (car looked-up)))] - [else #f])))] + (or + ; note that this may return #f, but we still want the print-hook to handle it + (language-pretty-print-size-hook (car looked-up) display? port) + (string-length (format "~s" (car looked-up))))] + [else + (language-pretty-print-size-hook value display? port)])))] [pretty-print-print-hook ; this print-hook is called for confusable highlights and for images. (lambda (value display? port) - (let ([to-display (cond - [(hash-ref highlight-table value (lambda () #f)) => car] - [else value])]) + (let ([looked-up (hash-ref highlight-table value (lambda () #f))]) (cond - [(is-a? to-display snip%) - (write-special (send to-display copy) port) (set-last-style)] + [(is-a? value snip%) + (write-special (send value copy) port) (set-last-style)] + [(and looked-up (not (eq? looked-up 'non-confusable))) + ; we have to call the size hook *again* to find + ; out if the underlying pretty-print-print-hook + ; can handle this + (define to-display (car looked-up)) + (if (language-pretty-print-size-hook to-display display? port) + (language-pretty-print-print-hook to-display display? port) + (write-string (format "~s" to-display) port))] [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)])))] + (language-pretty-print-print-hook value display? port)])))] + [pretty-print-print-line (lambda (number port old-length dest-columns) (when (and number (not (eq? number 0))) @@ -254,10 +275,14 @@ (select-all) (clear) (reset-style) + (define start (get-start-position)) (for ([exp stripped-exps] [i (in-naturals)]) (unless (= i 0) (insert #\newline)) (format-sexp exp)) + (define end (get-start-position)) + (change-style (send (get-style-list) find-named-style "Standard") + start end) (end-edit-sequence) (lock #t)) @@ -348,7 +373,8 @@ (define stepper-text% (class f:text:standard-style-list% - (init-field left-side right-side show-inexactness? print-boolean-long-form?) + (init-field left-side right-side show-inexactness? print-boolean-long-form? + language-pretty-print-size-hook language-pretty-print-print-hook) (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 @@ -415,8 +441,11 @@ (make-object stepper-sub-error-text% error-or-exps)] [else (make-object stepper-sub-text% - error-or-exps highlight-color show-inexactness? - print-boolean-long-form?)]))) + error-or-exps highlight-color + language-pretty-print-size-hook + language-pretty-print-print-hook + show-inexactness? + print-boolean-long-form?)]))) (setup-editor-snip before-snip left-side 'stepper:redex-highlight-color) (setup-editor-snip after-snip right-side 'stepper:reduct-highlight-color) diff --git a/htdp-lib/stepper/private/view-controller.rkt b/htdp-lib/stepper/private/view-controller.rkt index dce0466a..1c796a8d 100644 --- a/htdp-lib/stepper/private/view-controller.rkt +++ b/htdp-lib/stepper/private/view-controller.rkt @@ -10,6 +10,8 @@ (require racket/class racket/match racket/list + (only-in racket/pretty + pretty-print-size-hook pretty-print-print-hook) drracket/tool mred string-constants @@ -72,7 +74,7 @@ ;; render-to-sexp : TST -> sexp (define (render-to-sexp val) (send language-level stepper:render-to-sexp - val simple-settings language-level)) + val language-level)) ;; channel for incoming views (define view-channel (make-async-channel)) @@ -353,6 +355,10 @@ (set! disable-runaway-counter #t) #t])) + (define-values (language-pretty-print-size-hook + language-pretty-print-print-hook) + (send language-level stepper:pretty-print-hooks simple-settings + (pretty-print-size-hook) (pretty-print-print-hook))) ;; translates a result into a step ;; format-result : step-result -> step? @@ -362,6 +368,8 @@ (Step (new x:stepper-text% [left-side (map sstx-s pre-exps)] [right-side (map sstx-s post-exps)] + [language-pretty-print-size-hook language-pretty-print-size-hook] + [language-pretty-print-print-hook language-pretty-print-print-hook] [show-inexactness? (send language-level stepper:show-inexactness?)] [print-boolean-long-form? @@ -372,6 +380,8 @@ (Step (new x:stepper-text% [left-side (map sstx-s pre-exps)] [right-side err-msg] + [language-pretty-print-size-hook language-pretty-print-size-hook] + [language-pretty-print-print-hook language-pretty-print-print-hook] [show-inexactness? (send language-level stepper:show-inexactness?)] [print-boolean-long-form? @@ -382,6 +392,8 @@ (Step (new x:stepper-text% [left-side null] [right-side err-msg] + [language-pretty-print-size-hook language-pretty-print-size-hook] + [language-pretty-print-print-hook language-pretty-print-print-hook] [show-inexactness? (send language-level stepper:show-inexactness?)] [print-boolean-long-form? diff --git a/htdp-lib/stepper/stepper-tool.rkt b/htdp-lib/stepper/stepper-tool.rkt index 5b73ca12..234c1357 100644 --- a/htdp-lib/stepper/stepper-tool.rkt +++ b/htdp-lib/stepper/stepper-tool.rkt @@ -50,8 +50,16 @@ (public stepper:show-consumed-and/or-clauses?) (define (stepper:show-consumed-and/or-clauses?) #t) + (public stepper:configure-rendering) + (define (stepper:configure-rendering settings) + (error 'stepper:configure-rendering "this must be overridden")) + + (public stepper:pretty-print-hooks) + (define (stepper:pretty-print-hooks settings previous-size-hook previous-print-hook) + (error 'stepper:configure-rendering "this must be overridden")) + (public stepper:render-to-sexp) - (define (stepper:render-to-sexp val settings language-level) + (define (stepper:render-to-sexp val language-level) (when (boolean? val) (log-stepper-debug "render-to-sexp got a boolean: ~v\n" val)) (or (and (procedure? val)