diff --git a/collects/redex/gui.rkt b/collects/redex/gui.rkt index e44a923050..8b54bb057a 100644 --- a/collects/redex/gui.rkt +++ b/collects/redex/gui.rkt @@ -103,6 +103,7 @@ [default-pretty-printer (-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%) void?)] + [pretty-print-parameters (parameter/c (-> (-> any) any))] [current-pretty-printer (parameter/c (-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%) diff --git a/collects/redex/private/sexp-diffs.rkt b/collects/redex/private/sexp-diffs.rkt index c663e31fb5..2fc2a83b25 100644 --- a/collects/redex/private/sexp-diffs.rkt +++ b/collects/redex/private/sexp-diffs.rkt @@ -4,7 +4,8 @@ mrlib/graph scheme/pretty scheme/class - framework) + framework + "size-snip.rkt") (provide show-differences find-differences) @@ -90,8 +91,10 @@ ;; render-sexp/colors : sexp ht text -> void (define (render-sexp/colors sexp to-color text columns) (let ([start '()]) - (parameterize ([pretty-print-columns columns]) - (pretty-print sexp (open-output-text-editor text))) + ((pretty-print-parameters) + (λ () + (parameterize ([pretty-print-columns columns]) + (pretty-print sexp (open-output-text-editor text))))) (for-each (λ (p) (send text highlight-range (car p) (cdr p) (send the-color-database find-color "NavajoWhite"))) to-color) @@ -121,32 +124,34 @@ (set! pending-bytes (bytes)))) 1])) void)]) - (parameterize ([pretty-print-columns columns] - [pretty-print-remap-stylable - (λ (val) - (and (wrap? val) - (symbol? (wrap-content val)) - (wrap-content val)))] - [pretty-print-size-hook - (λ (val dsp? port) - (if (wrap? val) - (string-length (format "~s" (wrap-content val))) - #f))] - [pretty-print-print-hook - (λ (val dsp? port) - (write (wrap-content val) port))] - [pretty-print-pre-print-hook - (λ (obj port) - (when (hash-ref diff-ht obj #f) - (flush-output port) - (set! start (cons position start))))] - [pretty-print-post-print-hook - (λ (obj port) - (when (hash-ref diff-ht obj #f) - (flush-output port) - (set! to-color (cons (cons (car start) position) to-color)) - (set! start (cdr start))))]) - (pretty-print sexp counting-port)) + ((pretty-print-parameters) + (λ () + (parameterize ([pretty-print-columns columns] + [pretty-print-remap-stylable + (λ (val) + (and (wrap? val) + (symbol? (wrap-content val)) + (wrap-content val)))] + [pretty-print-size-hook + (λ (val dsp? port) + (if (wrap? val) + (string-length (format "~s" (wrap-content val))) + #f))] + [pretty-print-print-hook + (λ (val dsp? port) + (write (wrap-content val) port))] + [pretty-print-pre-print-hook + (λ (obj port) + (when (hash-ref diff-ht obj #f) + (flush-output port) + (set! start (cons position start))))] + [pretty-print-post-print-hook + (λ (obj port) + (when (hash-ref diff-ht obj #f) + (flush-output port) + (set! to-color (cons (cons (car start) position) to-color)) + (set! start (cdr start))))]) + (pretty-print sexp counting-port)))) to-color)) ;; does a map-like operation, but if the list is dotted, flattens the results into an actual list. diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index f0a7bc9851..6c2cc56334 100644 --- a/collects/redex/private/size-snip.rkt +++ b/collects/redex/private/size-snip.rkt @@ -10,6 +10,7 @@ size-text% default-pretty-printer current-pretty-printer + pretty-print-parameters initial-char-width resizing-pasteboard-mixin get-user-char-width) @@ -22,6 +23,8 @@ [(number? cw/proc) cw/proc] [else (cw/proc expr)])) +(define pretty-print-parameters (make-parameter (λ (thunk) (thunk)))) + (define (default-pretty-printer v port w spec) (parameterize ([pretty-print-columns w] [pretty-print-size-hook @@ -37,7 +40,9 @@ (display "hole" op)] [(eq? val 'hole) (display ",'hole" op)]))]) - (pretty-print v port))) + ((pretty-print-parameters) + (λ () + (pretty-print v port))))) (define current-pretty-printer (make-parameter default-pretty-printer)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index a2d8891527..99cc052836 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1748,6 +1748,17 @@ the color used to fill the arrowhead and the text colors control the color used to draw the label on the edge. } +@defparam[pretty-print-parameters f (-> (-> any/c) any/c)]{ + A parameter that is used to set other @racket[pretty-print] + parameters. + + Specifically, whenever @racket[default-pretty-printer] prints + something it calls @racket[f] with a thunk that does the actual + printing. Thus, @racket[f] can adjust @racket[pretty-print]'s + parameters to adjust how printing happens. + +} + @defparam[current-pretty-printer pp (-> any/c output-port? exact-nonnegative-integer? @@ -1761,7 +1772,9 @@ color used to draw the label on the edge. This is the default value of @racket[pp] used by @racket[traces] and @racket[stepper] and it uses -@racket[pretty-print]. +@racket[pretty-print]. + +This function uses the value of @racket[pretty-print-parameters] to adjust how it prints. It sets the @racket[pretty-print-columns] parameter to @racket[width], and it sets @racket[pretty-print-size-hook]