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

added normalization during pasting to eliminate various ligatures, etc

Browse Source 
svn: r12183

original commit: 47297fac9f1f9ca22d744d10cf2276cd6c446f82
This commit is contained in:
Robby Findler 2008-10-30 21:38:40 +00:00
parent 0f6ab108f6
commit e64c49d0bd
5 changed files with 443 additions and 331 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
collects/framework/private/main.ss
View File

@ -1,10 +1,10 @@
#lang scheme/unit #lang scheme/unit
(require mzlib/class (require mzlib/class
"sig.ss" "sig.ss"
"../preferences.ss" "../preferences.ss"
mred/mred-sig) mred/mred-sig)
(import mred^ (import mred^
[prefix preferences: framework:preferences^] [prefix preferences: framework:preferences^]
[prefix exit: framework:exit^] [prefix exit: framework:exit^]
[prefix group: framework:group^] [prefix group: framework:group^]
@ -12,18 +12,21 @@
[prefix editor: framework:editor^] [prefix editor: framework:editor^]
[prefix color-prefs: framework:color-prefs^] [prefix color-prefs: framework:color-prefs^]
[prefix scheme: framework:scheme^]) [prefix scheme: framework:scheme^])
(export framework:main^) (export framework:main^)
(init-depend framework:preferences^ framework:exit^ framework:editor^ (init-depend framework:preferences^ framework:exit^ framework:editor^
framework:color-prefs^ framework:scheme^) framework:color-prefs^ framework:scheme^)
(preferences:low-level-put-preferences preferences:put-preferences/gui) (preferences:low-level-put-preferences preferences:put-preferences/gui)
(application-preferences-handler (λ () (preferences:show-dialog))) (application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:replace-visible? #f boolean?) (preferences:set-default 'framework:ask-about-paste-normalization #t boolean?)
(preferences:set-default 'framework:anchored-search #f boolean?) (preferences:set-default 'framework:do-paste-normalization #t boolean?)
(let ([search/replace-string-predicate (preferences:set-default 'framework:replace-visible? #f boolean?)
(preferences:set-default 'framework:anchored-search #f boolean?)
(let ([search/replace-string-predicate
(λ (l) (λ (l)
(and (list? l) (and (list? l)
(andmap (andmap
@ -36,8 +39,8 @@
'() '()
search/replace-string-predicate)) search/replace-string-predicate))
;; marshalling for this one will just lose information. Too bad. ;; marshalling for this one will just lose information. Too bad.
(preferences:set-un/marshall 'framework:search-string (preferences:set-un/marshall 'framework:search-string
(λ (l) (λ (l)
(map (λ (x) (map (λ (x)
(if (is-a? x snip%) (if (is-a? x snip%)
@ -46,9 +49,9 @@
l)) l))
values) values)
(preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?) (preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?)
(preferences:set-default 'framework:square-bracket:cond/offset (preferences:set-default 'framework:square-bracket:cond/offset
'(("case-lambda" 0) '(("case-lambda" 0)
("cond" 0) ("cond" 0)
("field" 0) ("field" 0)
@ -63,10 +66,10 @@
(number? (cadr x)) (number? (cadr x))
(null? (cddr x)))) (null? (cddr x))))
x)))) x))))
(preferences:set-default 'framework:square-bracket:local (preferences:set-default 'framework:square-bracket:local
'("local") '("local")
(λ (x) (and (list? x) (andmap string? x)))) (λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:letrec (preferences:set-default 'framework:square-bracket:letrec
'("let" '("let"
"let*" "let-values" "let*-values" "let*" "let-values" "let*-values"
"let-syntax" "let-struct" "let-syntaxes" "let-syntax" "let-struct" "let-syntaxes"
@ -76,24 +79,24 @@
"with-syntax") "with-syntax")
(λ (x) (and (list? x) (andmap string? x)))) (λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:white-on-black? #f boolean?) (preferences:set-default 'framework:white-on-black? #f boolean?)
(preferences:set-default 'framework:case-sensitive-search? (preferences:set-default 'framework:case-sensitive-search?
#f #f
boolean?) boolean?)
(color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black") (color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
(preferences:set-default 'framework:special-meta-key #f boolean?) (preferences:set-default 'framework:special-meta-key #f boolean?)
(preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v))) (preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v)))
(map-command-as-meta-key (preferences:get 'framework:special-meta-key)) (map-command-as-meta-key (preferences:get 'framework:special-meta-key))
(preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper)))) (preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
(preferences:set-default 'framework:standard-style-list:font-name (preferences:set-default 'framework:standard-style-list:font-name
(get-family-builtin-face 'modern) (get-family-builtin-face 'modern)
string?) string?)
(preferences:set-default (preferences:set-default
'framework:standard-style-list:font-size 'framework:standard-style-list:font-size
(let* ([txt (make-object text%)] (let* ([txt (make-object text%)]
[stl (send txt get-style-list)] [stl (send txt get-style-list)]
@ -101,15 +104,15 @@
(send bcs get-size)) (send bcs get-size))
(λ (x) (and (number? x) (exact? x) (integer? x) (positive? x)))) (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
(preferences:set-default (preferences:set-default
'framework:standard-style-list:smoothing 'framework:standard-style-list:smoothing
'default 'default
(λ (x) (λ (x)
(memq x '(unsmoothed partly-smoothed smoothed default)))) (memq x '(unsmoothed partly-smoothed smoothed default))))
(editor:set-standard-style-list-pref-callbacks) (editor:set-standard-style-list-pref-callbacks)
(color-prefs:set-default/color-scheme (color-prefs:set-default/color-scheme
'framework:paren-match-color 'framework:paren-match-color
(let ([gray-level (let ([gray-level
;; old gray-level 192 ;; old gray-level 192
@ -119,7 +122,7 @@
(make-object color% gray-level gray-level gray-level)) (make-object color% gray-level gray-level gray-level))
(make-object color% 50 50 50)) (make-object color% 50 50 50))
(preferences:set-default 'framework:recently-opened-files/pos (preferences:set-default 'framework:recently-opened-files/pos
null null
(λ (x) (and (list? x) (λ (x) (and (list? x)
(andmap (andmap
@ -131,7 +134,7 @@
(number? (caddr x)))) (number? (caddr x))))
x)))) x))))
(preferences:set-un/marshall (preferences:set-un/marshall
'framework:recently-opened-files/pos 'framework:recently-opened-files/pos
(λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l)) (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
(λ (l) (λ (l)
@ -148,51 +151,51 @@
(cons (bytes->path (car x)) (cdr x))) (cons (bytes->path (car x)) (cdr x)))
l)))) l))))
(preferences:set-default 'framework:last-directory (preferences:set-default 'framework:last-directory
(find-system-path 'doc-dir) (find-system-path 'doc-dir)
(λ (x) (or (not x) path-string?))) (λ (x) (or (not x) path-string?)))
(preferences:set-un/marshall 'framework:last-directory (preferences:set-un/marshall 'framework:last-directory
(λ (x) (and (path? x) (path->bytes x))) (λ (x) (and (path? x) (path->bytes x)))
(λ (x) (λ (x)
(and (bytes? x) (and (bytes? x)
(bytes->path x)))) (bytes->path x))))
(preferences:set-default 'framework:recent-max-count (preferences:set-default 'framework:recent-max-count
50 50
(λ (x) (and (number? x) (λ (x) (and (number? x)
(x . > . 0) (x . > . 0)
(integer? x)))) (integer? x))))
(preferences:add-callback (preferences:add-callback
'framework:recent-max-count 'framework:recent-max-count
(λ (p v) (λ (p v)
(handler:size-recently-opened-files v))) (handler:size-recently-opened-files v)))
(preferences:set-default 'framework:last-url-string "" string?) (preferences:set-default 'framework:last-url-string "" string?)
(preferences:set-default 'framework:recently-opened-sort-by 'age (preferences:set-default 'framework:recently-opened-sort-by 'age
(λ (x) (or (eq? x 'age) (eq? x 'name)))) (λ (x) (or (eq? x 'age) (eq? x 'name))))
(preferences:set-default 'framework:recent-items-window-w 400 number?) (preferences:set-default 'framework:recent-items-window-w 400 number?)
(preferences:set-default 'framework:recent-items-window-h 600 number?) (preferences:set-default 'framework:recent-items-window-h 600 number?)
(preferences:set-default 'framework:open-here? #f boolean?) (preferences:set-default 'framework:open-here? #f boolean?)
(preferences:set-default 'framework:show-delegate? #f boolean?) (preferences:set-default 'framework:show-delegate? #f boolean?)
(preferences:set-default 'framework:windows-mdi #f boolean?) (preferences:set-default 'framework:windows-mdi #f boolean?)
(preferences:set-default 'framework:menu-bindings #t boolean?) (preferences:set-default 'framework:menu-bindings #t boolean?)
(preferences:set-default 'framework:verify-change-format #f boolean?) (preferences:set-default 'framework:verify-change-format #f boolean?)
(preferences:set-default 'framework:auto-set-wrap? #t boolean?) (preferences:set-default 'framework:auto-set-wrap? #t boolean?)
(preferences:set-default 'framework:display-line-numbers #t boolean?) (preferences:set-default 'framework:display-line-numbers #t boolean?)
(preferences:set-default 'framework:show-status-line #t boolean?) (preferences:set-default 'framework:show-status-line #t boolean?)
(preferences:set-default 'framework:col-offsets #f boolean?) (preferences:set-default 'framework:col-offsets #f boolean?)
(preferences:set-default (preferences:set-default
'framework:print-output-mode 'framework:print-output-mode
'standard 'standard
(λ (x) (or (eq? x 'standard) (eq? x 'postscript)))) (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
(preferences:set-default 'framework:highlight-parens #t boolean?) (preferences:set-default 'framework:highlight-parens #t boolean?)
(preferences:set-default 'framework:fixup-parens #t boolean?) (preferences:set-default 'framework:fixup-parens #t boolean?)
(preferences:set-default 'framework:fixup-open-parens #t boolean?) (preferences:set-default 'framework:fixup-open-parens #t boolean?)
(preferences:set-default 'framework:paren-match #t boolean?) (preferences:set-default 'framework:paren-match #t boolean?)
(let ([hash-table (make-hasheq)]) (let ([hash-table (make-hasheq)])
(for-each (λ (x) (for-each (λ (x)
(hash-set! hash-table x 'define)) (hash-set! hash-table x 'define))
'(local)) '(local))
@ -275,18 +278,18 @@
(cons h (cdr l))))))) (cons h (cdr l)))))))
(preferences:set-default 'framework:autosave-delay 300 number?) (preferences:set-default 'framework:autosave-delay 300 number?)
(preferences:set-default 'framework:autosaving-on? #t boolean?) (preferences:set-default 'framework:autosaving-on? #t boolean?)
(preferences:set-default 'framework:backup-files? #t boolean?) (preferences:set-default 'framework:backup-files? #t boolean?)
(preferences:set-default 'framework:verify-exit #t boolean?) (preferences:set-default 'framework:verify-exit #t boolean?)
(preferences:set-default 'framework:delete-forward? #t boolean?) (preferences:set-default 'framework:delete-forward? #t boolean?)
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?) (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
(preferences:set-default 'framework:file-dialogs 'std (preferences:set-default 'framework:file-dialogs 'std
(λ (x) (and (memq x '(common std)) #t))) (λ (x) (and (memq x '(common std)) #t)))
;; scheme prefs ;; scheme prefs
(for-each (λ (line white-on-black-line) (for-each (λ (line white-on-black-line)
(let ([sym (car line)] (let ([sym (car line)]
[color (cadr line)] [color (cadr line)]
[white-on-black-color (cadr white-on-black-line)]) [white-on-black-color (cadr white-on-black-line)])
@ -297,36 +300,34 @@
white-on-black-color))) white-on-black-color)))
(scheme:get-color-prefs-table) (scheme:get-color-prefs-table)
(scheme:get-white-on-black-color-prefs-table)) (scheme:get-white-on-black-color-prefs-table))
(preferences:set-default 'framework:coloring-active #t boolean?) (preferences:set-default 'framework:coloring-active #t boolean?)
(color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white") (color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
(preferences:add-callback 'framework:default-text-color (preferences:add-callback 'framework:default-text-color
(λ (p v) (λ (p v)
(editor:set-default-font-color v))) (editor:set-default-font-color v)))
(editor:set-default-font-color (preferences:get 'framework:default-text-color)) (editor:set-default-font-color (preferences:get 'framework:default-text-color))
(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
"light blue" "light blue"
(make-object color% 62 67 155)) (make-object color% 62 67 155))
;; groups ;; groups
(preferences:set-default 'framework:exit-when-no-frames #t boolean?) (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
(unless (preferences:get 'framework:exit-when-no-frames) (unless (preferences:get 'framework:exit-when-no-frames)
(preferences:set 'framework:exit-when-no-frames #t)) (preferences:set 'framework:exit-when-no-frames #t))
(exit:insert-can?-callback (exit:insert-can?-callback
(λ () (λ ()
(send (group:get-the-frame-group) can-close-all?))) (send (group:get-the-frame-group) can-close-all?)))
(exit:insert-on-callback (exit:insert-on-callback
(λ () (λ ()
(send (group:get-the-frame-group) on-close-all))) (send (group:get-the-frame-group) on-close-all)))
;; reset these -- they are only for the test suite. ;; reset these -- they are only for the test suite.
;; they do not need to be set across starting up and shutting down ;; they do not need to be set across starting up and shutting down
;; the application. ;; the application.
;(preferences:set 'framework:file-dialogs 'std) ;(preferences:set 'framework:file-dialogs 'std)
;; setup the color scheme stuff

4
collects/framework/private/preferences.ss
View File

@ -443,6 +443,10 @@ the state transitions / contracts are:
'framework:anchored-search 'framework:anchored-search
(string-constant find-anchor-based) (string-constant find-anchor-based)
values values) values values)
(make-check editor-panel
'framework:do-paste-normalization
(string-constant normalize-string-preference)
values values)
(editor-panel-procs editor-panel))))]) (editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel))) (add-editor-checkbox-panel)))

3
collects/framework/private/sig.ss
View File

@ -163,6 +163,7 @@
foreground-color<%> foreground-color<%>
hide-caret/selection<%> hide-caret/selection<%>
nbsp->space<%> nbsp->space<%>
normalize-paste<%>
delegate<%> delegate<%>
wide-snip<%> wide-snip<%>
searching<%> searching<%>
@ -177,6 +178,7 @@
basic% basic%
hide-caret/selection% hide-caret/selection%
nbsp->space% nbsp->space%
normalize-paste%
1-pixel-string-snip% 1-pixel-string-snip%
1-pixel-tab-snip% 1-pixel-tab-snip%
delegate% delegate%
@ -197,6 +199,7 @@
foreground-color-mixin foreground-color-mixin
hide-caret/selection-mixin hide-caret/selection-mixin
nbsp->space-mixin nbsp->space-mixin
normalize-paste-mixin
wide-snip-mixin wide-snip-mixin
delegate-mixin delegate-mixin
searching-mixin searching-mixin

79
collects/framework/private/text.ss
View File

@ -821,7 +821,83 @@ WARNING: printf is rebound in the body of the unit to always
(set! rewriting #f)) (set! rewriting #f))
(end-edit-sequence) (end-edit-sequence)
(inner (void) after-insert start len)) (inner (void) after-insert start len))
(super-instantiate ()))) (super-new)))
(define normalize-paste<%> (interface ((class->interface text%))
ask-normalize?
string-normalize))
(define normalize-paste-mixin
(mixin (basic<%>) (normalize-paste<%>)
(inherit begin-edit-sequence end-edit-sequence
delete insert split-snip find-snip
get-snip-position get-top-level-window find-string)
(define pasting? #f)
(define rewriting? #f)
(define/public (ask-normalize?)
(cond
[(preferences:get 'framework:ask-about-paste-normalization)
(let-values ([(mbr checked?)
(message+check-box/custom
(string-constant drscheme)
(string-constant normalize-string-info)
(string-constant dont-ask-again)
(string-constant normalize)
(string-constant leave-alone)
#f
(get-top-level-window)
(cons (if (preferences:get 'framework:do-paste-normalization)
'default=1
'default=2)
'(caution))
2)])
(let ([normalize? (not (equal? 2 mbr))])
(preferences:set 'framework:ask-about-paste-normalization (not checked?))
(preferences:set 'framework:do-paste-normalization normalize?)
normalize?))]
[else
(preferences:get 'framework:do-paste-normalization)]))
(define/public (string-normalize s) (string-normalize-nfkc s))
(define/override (do-paste start time)
(dynamic-wind
(λ () (set! pasting? #t))
(λ () (super do-paste start time))
(λ () (set! pasting? #f))))
(define/augment (on-insert start len)
(inner (void) on-insert start len)
(begin-edit-sequence))
(define/augment (after-insert start len)
(when pasting?
(unless rewriting?
(set! rewriting? #t)
(let/ec abort
(define ask? #t)
(split-snip start)
(split-snip (+ start len))
(let loop ([snip (find-snip start 'after-or-none)])
(when snip
(let ([next (send snip next)])
(when (is-a? snip string-snip%)
(let* ([old (send snip get-text 0 (send snip get-count))]
[new (string-normalize old)])
(unless (equal? new old)
(when ask?
(set! ask? #f)
(unless (ask-normalize?) (abort)))
(let ([snip-pos (get-snip-position snip)])
(delete snip-pos (+ snip-pos (string-length old)))
(insert new snip-pos snip-pos #f)))))
(loop next)))))
(set! rewriting? #f)))
(end-edit-sequence)
(inner (void) after-insert start len))
(super-new)))
(define searching<%> (define searching<%>
(interface (editor:keymap<%> basic<%>) (interface (editor:keymap<%> basic<%>)
@ -3644,6 +3720,7 @@ designates the character that triggers autocompletion
(define basic% (basic-mixin (editor:basic-mixin text%))) (define basic% (basic-mixin (editor:basic-mixin text%)))
(define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define hide-caret/selection% (hide-caret/selection-mixin basic%))
(define nbsp->space% (nbsp->space-mixin basic%)) (define nbsp->space% (nbsp->space-mixin basic%))
(define normalize-paste% (normalize-paste-mixin basic%))
(define delegate% (delegate-mixin basic%)) (define delegate% (delegate-mixin basic%))
(define wide-snip% (wide-snip-mixin basic%)) (define wide-snip% (wide-snip-mixin basic%))
(define standard-style-list% (editor:standard-style-list-mixin wide-snip%)) (define standard-style-list% (editor:standard-style-list-mixin wide-snip%))

27
collects/scribblings/framework/text.scrbl
View File

@ -302,6 +302,33 @@
@method[text:nbsp->space-mixin on-insert]. @method[text:nbsp->space-mixin on-insert].
} }
} }
@definterface[text:normalize-paste<%> (text:basic<%>)]{
@defmethod[(ask-normalize?) boolean?]{
Prompts the user if the pasted text should be normalized
(and updates various preferences based on the response).
Override this method in the mixin to avoid all GUI and preferences interactions.
}
@defmethod[(string-normalize [s string?]) string?]{
Normalizes @scheme[s]. Defaults to @scheme[string-normalize-nfkc].
}
}
@defmixin[text:normalize-paste-mixin (text:basic<%>) (text:normalize-paste<%>)]{
@defmethod[#:mode override (do-paste [start exact-nonnegative-integer?] [time (and/c exact? integer?)]) void?]{
Overridden to detect when insertions are due to pasting. Sets some internal state and calls the super.
}
@defmethod[#:mode augment (on-insert [start exact-nonnegative-integer?] [len exact-nonnegative-integer?]) void?]{
Calls @method[editor<%> begin-edit-sequence].
}
@defmethod[#:mode augment (after-insert [start exact-nonnegative-integer?] [len exact-nonnegative-integer?]) void?]{
Normalizes any next text and calls @method[editor<%> end-edit-sequence].
}
}
@definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{ @definterface[text:searching<%> (editor:keymap<%> text:basic<%>)]{
Any object matching this interface can be searched. Any object matching this interface can be searched.