<div dir="ltr">Why not just use the pp argument that's already there? (And I think your editor is indenting improperly; some of those lines don't seem to have changed except indentation)<div> </div><div>Robby</div> </div><div class="gmail_extra"> <div class="gmail_quote">On Thu, May 2, 2013 at 3:02 PM, J. Ian Johnson <<a href="mailto:ianj@ccs.neu.edu" target="_blank">ianj@ccs.neu.edu</a>> wrote: <blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">Okay, here's a diff that hacks it in for my purposes and doesn't crash. I don't know what this breaks due to the new init-field in size-snip though. Will anyone familiar with this part of the codebase please comment? Thanks, -Ian diff --git a/collects/redex/gui.rkt b/collects/redex/gui.rkt index 41dce2a..ddd291b 100644 --- a/collects/redex/gui.rkt +++ b/collects/redex/gui.rkt @@ -43,6 +43,7 @@ #:edge-label-font (or/c #f (is-a?/c font%)) #:edge-labels? boolean? #:filter (-> any/c (or/c #f string?) any/c) + #:format (-> any/c any/c) #:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>)) any)] [traces/ps (->* (reduction-relation? @@ -60,6 +61,7 @@ #:edge-label-font (or/c #f (is-a?/c font%)) #:edge-labels? boolean? #:filter (-> any/c (or/c #f string?) any/c) + #:format (-> any/c any/c) #:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>) #:post-process (-> (is-a?/c graph-pasteboard<%>) any/c)) any)] diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index e505ba5..3cf8676 100644 --- a/collects/redex/private/size-snip.rkt +++ b/collects/redex/private/size-snip.rkt @@ -83,6 +83,7 @@ (define size-editor-snip% (class* editor-snip% (reflowing-snip<%>) (init-field expr) + (init-field formatted-expr) (init pp) (init-field char-width) (define real-pp @@ -172,7 +173,7 @@ (send text thaw-colorer)) (send text set-styles-sticky #f) (send text erase) - (real-pp expr port char-width text) + (real-pp formatted-expr port char-width text) diff --git a/collects/redex/private/traces.rkt b/collects/redex/private/traces.rkt index 1293c19..9bcb45a 100644 --- a/collects/redex/private/traces.rkt +++ b/collects/redex/private/traces.rkt @@ -139,6 +139,7 @@ #:edge-labels? [edge-labels? #t] #:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values] #:filter [term-filter (lambda (x y) #t)] + #:format [term-formatter values] #:post-process [post-process void] #:x-spacing [x-spacing default-x-spacing] #:y-spacing [y-spacing default-x-spacing]) @@ -156,6 +157,7 @@ #:edge-labels? edge-labels? #:graph-pasteboard-mixin extra-graph-pasteboard-mixin #:filter term-filter + #:format term-formatter #:x-spacing x-spacing #:y-spacing y-spacing)]) (post-process graph-pb) @@ -249,6 +251,7 @@ #:edge-label-font [edge-label-font #f] #:edge-labels? [edge-labels? #t] #:filter [term-filter (lambda (x y) #t)] + #:format [term-formatter values] #:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values] #:no-show-frame? [no-show-frame? #f] #:x-spacing [x-spacing default-x-spacing] @@ -368,7 +371,7 @@ (filter (λ (x) x) (map (lambda (expr) (apply build-snip - snip-cache #f expr pred pp #f code-colors? + snip-cache #f expr pred term-formatter pp #f code-colors? (get-user-char-width user-char-width expr) default-colors)) exprs))) @@ -429,20 +432,20 @@ (let* ([snip (car snips)] [new-snips (filter - (lambda (x) x) + values (map (lambda (red+sexp) (let-values ([(name sexp) (apply values red+sexp)]) (call-on-eventspace-main-thread (λ () - (and (term-filter sexp name) - (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color - dark-pen-color - light-pen-color) - (red->colors name)]) - (build-snip snip-cache snip sexp pred pp name code-colors? - (get-user-char-width user-char-width sexp) - light-arrow-color dark-arrow-color dark-label-color light-label-color - dark-pen-color light-pen-color))))))) + (and (term-filter sexp name) + (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color + dark-pen-color + light-pen-color) + (red->colors name)]) + (build-snip snip-cache snip sexp pred term-formatter pp name code-colors? + (get-user-char-width user-char-width sexp) + light-arrow-color dark-arrow-color dark-label-color light-label-color + dark-pen-color light-pen-color))))))) (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))] [new-y (call-on-eventspace-main-thread @@ -787,6 +790,7 @@ ;; (union #f (is-a?/c graph-snip<%>)) ;; sexp ;; sexp -> boolean +;; sexp -> sexp ;; (any port number -> void) ;; (union #f string) ;; number @@ -795,7 +799,7 @@ ;; returns #f if a snip corresponding to the expr has already been created. ;; also adds in the links to the parent snip ;; =eventspace main thread= -(define (build-snip cache parent-snip expr pred pp name code-colors? cw +(define (build-snip cache parent-snip expr pred formatter pp name code-colors? cw light-arrow-color dark-arrow-color dark-label-color light-label-color dark-brush-color light-brush-color) (let-values ([(snip new?) @@ -804,7 +808,7 @@ cache expr (lambda () - (let ([new-snip (make-snip parent-snip expr pred pp code-colors? cw)]) + (let ([new-snip (make-snip parent-snip expr pred formatter pp code-colors? cw)]) (hash-set! cache expr new-snip) @@ -824,7 +828,7 @@ (make-object color% light-label-color)) 0 0 name) - (update-badness pred parent-snip (send parent-snip get-expr))) + (update-badness pred parent-snip (formatter (send parent-snip get-expr)))) (update-badness pred snip expr) @@ -845,20 +849,22 @@ ;; make-snip : (union #f (is-a?/c graph-snip<%>)) ;; sexp ;; sexp -> boolean +;; sexp -> sexp ;; (any port number -> void) ;; boolean ;; number ;; -> (is-a?/c graph-editor-snip%) ;; unconditionally creates a new graph-editor-snip ;; =eventspace main thread= -(define (make-snip parent-snip expr pred pp code-colors? cw) +(define (make-snip parent-snip expr pred formatter pp code-colors? cw) (let* ([text (new program-text%)] [es (instantiate graph-editor-snip% () (char-width cw) (editor text) (my-eventspace (current-eventspace)) (pp pp) - (expr expr))]) + (expr expr) + (formatted-expr (formatter expr)))]) (send text set-autowrap-bitmap #f) (send text set-max-width 'none) (send text freeze-colorer) <div class="HOEnZb"><div class="h5"> ----- Original Message ----- From: "J. Ian Johnson" <<a href="mailto:ianj@ccs.neu.edu">ianj@ccs.neu.edu</a>> To: "users" <<a href="mailto:users@racket-lang.org">users@racket-lang.org</a>> Sent: Thursday, May 2, 2013 2:46:17 PM GMT -05:00 US/Canada Eastern Subject: [racket] Trimmed view in redex's traces? I'm trying to debug an abstract machine with some large auxiliary tables. Is there a way to make traces only show a portion of a term, but still treat the box it's in as the entire term? An additional bonus would be to drill down into a trimmed box via click or something. I don't see this in the docs, so I'm guessing no, but an extra keyword argument for a term -> term "trimming" function shouldn't be too hard to add, right? Just not sure where to change this. -Ian ____________________ Racket Users list: <a href="http://lists.racket-lang.org/users" target="_blank">http://lists.racket-lang.org/users</a> ____________________ Racket Users list: <a href="http://lists.racket-lang.org/users" target="_blank">http://lists.racket-lang.org/users</a> </div></div></blockquote></div> </div>