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)
----- Original Message -----
From: "J. Ian Johnson" <i...@ccs.neu.edu>
To: "users" <users@racket-lang.org>
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:
http://lists.racket-lang.org/users
____________________
Racket Users list:
http://lists.racket-lang.org/users
