suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add a column-width guide; defaults to 102 characters, but disabled

Browse Source 
original commit: 09d636c54573522449a6591c805b38f72b6f7da8
This commit is contained in:
Robby Findler 2013-06-10 22:50:46 -05:00
parent cc18191061
commit 3a989db884
4 changed files with 144 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/framework/private/main.rkt
View File

@ -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?

44
collects/framework/private/preferences.rkt
View File

@ -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)))

2
collects/framework/private/sig.rkt
View File

@ -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

94
collects/framework/private/text.rkt
View File

@ -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))