From 3a989db88436f8485d7561440354a36866aa2801 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 10 Jun 2013 22:50:46 -0500 Subject: [PATCH] add a column-width guide; defaults to 102 characters, but disabled original commit: 09d636c54573522449a6591c805b38f72b6f7da8 --- collects/framework/private/main.rkt | 4 + collects/framework/private/preferences.rkt | 44 ++++++++++ collects/framework/private/sig.rkt | 2 + collects/framework/private/text.rkt | 94 ++++++++++++++++++++++ 4 files changed, 144 insertions(+) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 2ff22aec..059c7630 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -24,6 +24,10 @@ (application-preferences-handler (λ () (preferences:show-dialog))) +(preferences:set-default 'framework:column-guide-width + '(#f 102) + (list/c boolean? (and/c exact-integer? (>=/c 2)))) + (preferences:set-default 'framework:aspell-dict #f (λ (x) (or (not x) (string? x)))) (preferences:set-default 'framework:line-spacing-add-gap? diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index f2fc0259..2b38e753 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -494,6 +494,50 @@ the state transitions / contracts are: (add-check editor-panel 'framework:line-spacing-add-gap? (string-constant add-spacing-between-lines)) + + (let ([hp (new horizontal-panel% [parent editor-panel] [stretchable-height #f])] + [init-pref (preferences:get 'framework:column-guide-width)]) + (define on-cb + (new check-box% + [parent hp] + [label (string-constant maximum-char-width-guide-pref-check-box)] + [value (car init-pref)] + [callback + (λ (x y) + (update-pref) + (update-tf-bkg) + (send tf enable (send on-cb get-value)))])) + (define tf + (new text-field% + [label #f] + [parent hp] + [init-value (format "~a" (cadr init-pref))] + [callback + (λ (x y) + (update-pref) + (update-tf-bkg))])) + (define (update-tf-bkg) + (send tf set-field-background + (send the-color-database find-color + (cond + [(not (send on-cb get-value)) "gray"] + [(good-val? (string->number (send tf get-value))) + "white"] + [else + "yellow"])))) + (define (good-val? n) + (and (exact-integer? n) + (>= n 2))) + (define (update-pref) + (define current (preferences:get 'framework:column-guide-width)) + (define candidate-num (string->number (send tf get-value))) + (preferences:set 'framework:column-guide-width + (list (send on-cb get-value) + (if (good-val? candidate-num) + candidate-num + (cadr current))))) + (update-tf-bkg)) + (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index f75d722e..0c156b6d 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -187,6 +187,7 @@ foreground-color<%> hide-caret/selection<%> nbsp->space<%> + column-guide<%> normalize-paste<%> delegate<%> wide-snip<%> @@ -227,6 +228,7 @@ foreground-color-mixin hide-caret/selection-mixin nbsp->space-mixin + column-guide-mixin normalize-paste-mixin wide-snip-mixin delegate-mixin diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index c88f06fa..8c49dc58 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -883,6 +883,100 @@ (inner (void) after-insert start len)) (super-new))) +(define column-guide<%> (interface ((class->interface text%)))) +(define column-guide-mixin-pen-size 2) +(define column-guide-mixin + (mixin ((class->interface text%)) (column-guide<%>) + (inherit get-style-list invalidate-bitmap-cache get-dc + begin-edit-sequence end-edit-sequence + get-extent get-padding) + (define char-width #f) + (define pen #f) + ;; these two functions are defined as private fields + ;; because they are weakly held callbacks + (define (bw-cb p v) + (set! pen + (send the-pen-list find-or-create-pen + (if v + (make-object color% 225 225 51) + (make-object color% 204 204 51)) + (* column-guide-mixin-pen-size 2) + 'solid))) + (define (cw-cb p v) + (define new-cw (and (car v) (cadr v))) + (unless (equal? new-cw char-width) + (define (inv cw) + (define x-pos (get-x-spot cw)) + (when x-pos + (invalidate-bitmap-cache + (- x-pos (send pen get-width)) + 0 + (+ x-pos (send pen get-width)) + 'end))) + (define old-char-w char-width) + (set! char-width new-cw) + (begin-edit-sequence) + (inv old-char-w) + (inv char-width) + (end-edit-sequence))) + + (super-new) + + (preferences:add-callback 'framework:white-on-black? bw-cb #t) + (bw-cb 'ignored-arg (preferences:get 'framework:white-on-black?)) + + (preferences:add-callback 'framework:column-guide-width cw-cb #t) + (cw-cb 'ignored-arg (preferences:get 'framework:column-guide-width)) + + (define aw (box 0.0)) + (define ah (box 0.0)) + (define left-padding 0) + + (define/augment (on-change) + (inner (void) on-change) + (define old-aw (unbox aw)) + (define old-ah (unbox ah)) + (get-extent aw ah) + (define-values (left top right bottom) (get-padding)) + (unless (and (= old-aw (unbox aw)) + (= old-ah (unbox ah)) + (= left left-padding)) + (set! left-padding left) + (invalidate-bitmap-cache))) + + (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 char-width + (when before? + (define x-pos (get-x-spot char-width)) + (when x-pos + (define old-pen (send dc get-pen)) + (send dc set-pen pen) + (when (< x-pos (- (unbox aw) 3)) + (send dc draw-line + (+ dx x-pos) + (+ dy top column-guide-mixin-pen-size) + (+ dx x-pos) + (+ dy (min (unbox ah) bottom) (- column-guide-mixin-pen-size)))) + (send dc set-pen old-pen))))) + + (define/private (get-x-spot char-width) + (cond + [char-width + (define dc (get-dc)) + (cond + [dc + (define style (or (send (get-style-list) find-named-style "Standard") + (send (get-style-list) find-named-style "Basic"))) + (cond + [style + (define fnt (send style get-font)) + (define-values (xw _1 _2 _3) (send dc get-text-extent "x" fnt)) + (+ left-padding (* xw char-width))] + [else #f])] + [else #f])] + [else #f])))) + (define normalize-paste<%> (interface ((class->interface text%)) ask-normalize? string-normalize))