[plt-scheme] Parentheses and color

On 7/5/07, Dave Gurnell <d.j.gurnell at gmail.com> wrote:
> >> Note to the free-software users here:  this appears to be a photoshop
> > file, and the gimp can display it.  I used the version from etch (I
> > think 2.2.13).
>
> My mistake. I meant to save it as PNG, but obviously I hit the wrong
> option.
>
>      http://www.davegurnell.com/files/
> drscheme_with_column_highlighting.png

FWIW, that is relatively easy to accomplish with a tool. Put the two
below modules into files and put them into a collection (and run
setup-plt on that collection, so it gets registered with drscheme) et
voila.

Robby

(module info (lib "infotab.ss" "setup")
  (define name "Column Highlighting")
  (define tool-names (list "Column Highlighting"))
  (define tools (list "column.ss")))

(module column mzscheme
  (require (lib "framework.ss" "framework")
           (lib "class.ss")
           (lib "mred.ss" "mred"))

  (define column-width 5)
  (define column-color "lavender")

  (define column-mixin
    (mixin ((class->interface text%)) ()
      (define/override (on-paint before? dc left top right bottom dx
dy draw-caret)
        (super on-paint before? dc left top right bottom dx dy draw-caret)
        (when before?
          (let ([column-width-pixels (get-column-width-pixels dc)]
                [pen (send dc get-pen)]
                [brush (send dc get-brush)])
            (send dc set-pen column-color 1 'solid)
            (send dc set-brush column-color 'solid)
            (let loop ([x 0])
              (when (< x right)
                (when (<= left (+ x column-width-pixels))
                  (send dc draw-rectangle
                        (+ x dx)
                        (+ top dy)
                        column-width-pixels
                        (- bottom top)))
                (loop (+ x column-width-pixels column-width-pixels))))
            (send dc set-pen pen)
            (send dc set-brush brush))))
      (super-new)))

  (define (get-column-width-pixels dc)
    (let ([style (send (editor:get-standard-style-list)
                       find-named-style
                       "Standard")])
      (let-values ([(w _1 _2 _3) (send dc get-text-extent "x"
                                       (send style get-font))])
        (* w column-width))))

  ;; code to test, w/out running inside drscheme
  #;
  (let ()
    (define f (new frame% [label ""] [width 400] [height 600]))
    (define t (new (column-mixin text%)))
    (define ec (new editor-canvas% [parent f] [editor t]))
    (send t load-file (build-path (collection-path "drscheme")
"private" "rep.ss"))
    (send t change-style (make-object style-delta% 'change-family
'modern) 0 (send t last-position))
    (send f show #t))


  ;; tool integration
  (require (lib "tool.ss" "drscheme")
           (lib "unit.ss"))
  (define tool@
    (unit
      (import drscheme:tool^)
      (export drscheme:tool-exports^)
      (define phase1 void)
      (define phase2 void)
      (drscheme:get/extend:extend-definitions-text
       column-mixin)))
  (provide tool@))