In stepper, respect the number-display format of the language. (#246)

In stepper, respect the number-display format of the language.

To that end, call the underlying pretty-print-print-handler
instead of format, and transform write-special'ed number markup into the corresponding snip.

Also, add a method to the stepper language to enable the language to provide appropriate pretty-print handlers.

Author: mikesperber

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)

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 ())))
-
-
-

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)))

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)

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?

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)