[racket] Trimmed view in redex's traces?

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)

Robby


On Thu, May 2, 2013 at 3:02 PM, J. Ian Johnson <ianj at ccs.neu.edu> wrote:

> 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" <ianj at ccs.neu.edu>
> To: "users" <users at 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
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20130502/acc8ec1d/attachment.html>