From c4630e45267412423a975d33532b6d4dc76258d1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 19 Jan 2009 15:15:12 +0000 Subject: [PATCH] extended initial-char-width svn: r13221 --- collects/redex/gui.ss | 2 +- collects/redex/private/size-snip.ss | 9 ++++++++- collects/redex/private/stepper.ss | 2 +- collects/redex/private/traces.ss | 16 ++++++++++++---- collects/redex/redex.scrbl | 6 +++++- doc/release-notes/redex/HISTORY.txt | 5 +++++ 6 files changed, 32 insertions(+), 8 deletions(-) diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index ffcf27c6a5..0977894e84 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -86,7 +86,7 @@ [dark-text-color (parameter/c (or/c string? (is-a?/c color%)))] [light-text-color (parameter/c (or/c string? (is-a?/c color%)))] [initial-font-size (parameter/c number?)] - [initial-char-width (parameter/c number?)]) + [initial-char-width (parameter/c (or/c number? (-> any/c number?)))]) (provide reduction-steps-cutoff default-pretty-printer) diff --git a/collects/redex/private/size-snip.ss b/collects/redex/private/size-snip.ss index 445157d7af..a58250a513 100644 --- a/collects/redex/private/size-snip.ss +++ b/collects/redex/private/size-snip.ss @@ -10,10 +10,17 @@ size-text% default-pretty-printer initial-char-width - resizing-pasteboard-mixin) + resizing-pasteboard-mixin + get-user-char-width) (define initial-char-width (make-parameter 30)) +;; get-user-char-width : value-bound-to-'initial-char-width'-parameter sexp -> number +(define (get-user-char-width cw/proc expr) + (cond + [(number? cw/proc) cw/proc] + [else (cw/proc expr)])) + (define (default-pretty-printer v port w spec) (parameterize ([pretty-print-columns w] [pretty-print-size-hook diff --git a/collects/redex/private/stepper.ss b/collects/redex/private/stepper.ss index 69d3bbd519..a819844bce 100644 --- a/collects/redex/private/stepper.ss +++ b/collects/redex/private/stepper.ss @@ -716,7 +716,7 @@ todo: [node node] [editor txt] [expr sexp] - [char-width init-cw])]) + [char-width (get-user-char-width init-cw sexp)])]) (send txt set-autowrap-bitmap #f) #;(send txt freeze-colorer) (send s format-expr) diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index e1e4261d5e..175945a751 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -238,6 +238,7 @@ (define main-eventspace (current-eventspace)) (define saved-parameterization (current-parameterization)) (define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font])) + (define user-char-width (initial-char-width)) (define f (instantiate red-sem-frame% () (label "PLT Redex Reduction Graph") (style '(toolbar-button)) @@ -331,6 +332,7 @@ (define default-colors (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color) (dark-brush-color) (light-brush-color))) + ;; only changed on the reduction thread ;; frontier : (listof (is-a?/c graph-editor-snip%)) @@ -339,9 +341,11 @@ (λ (x) x) (map (lambda (expr) (apply build-snip snip-cache #f expr pred pp #f scheme-colors? + (get-user-char-width user-char-width expr) default-colors)) exprs))) + ;; set-font-size : number -> void ;; =eventspace main thread= (define (set-font-size size) @@ -408,6 +412,7 @@ light-pen-color) (red->colors name)]) (build-snip snip-cache snip sexp pred pp name scheme-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))))] @@ -719,12 +724,13 @@ ;; sexp -> boolean ;; (any port number -> void) ;; (union #f string) +;; number ;; color^6 ;; -> (union #f (is-a?/c graph-editor-snip%)) ;; 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 scheme-colors? +(define (build-snip cache parent-snip expr pred pp name scheme-colors? cw light-arrow-color dark-arrow-color dark-label-color light-label-color dark-brush-color light-brush-color) (let-values ([(snip new?) @@ -733,7 +739,7 @@ cache expr (lambda () - (let ([new-snip (make-snip parent-snip expr pred pp scheme-colors?)]) + (let ([new-snip (make-snip parent-snip expr pred pp scheme-colors? cw)]) (hash-set! cache expr new-snip) (k new-snip #t)))) #f))]) @@ -775,13 +781,15 @@ ;; sexp ;; sexp -> boolean ;; (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 scheme-colors?) +(define (make-snip parent-snip expr pred pp scheme-colors? cw) (let* ([text (new program-text%)] [es (instantiate graph-editor-snip% () - (char-width (initial-char-width)) + (char-width cw) (editor text) (my-eventspace (current-eventspace)) (pp pp) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 8c5504304b..df244e859f 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1367,11 +1367,15 @@ A parameter that controls the initial font size for the terms shown in the GUI window. } -@defparam[initial-char-width width number?]{ +@defparam[initial-char-width width (or/c number? (-> any/c number?))]{ A parameter that determines the initial width of the boxes where terms are displayed (measured in characters) for both the stepper and traces. + +If its value is a number, then the number is used as the width for +every term. If its value is a function, then the function is called +with each term and the resulting number is used as the width. } @deftogether[[ diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index c595e7ad5b..4dc7754550 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,8 @@ +v4.1.4 + + - initial-char-width now accepts functions to give finer grained + control of the initial widths of the terms. + v4.1.3 * added redex-check, a tool for automatically generating test cases