added normalization during pasting to eliminate various ligatures, etc

svn: r12183

original commit: 47297fac9f1f9ca22d744d10cf2276cd6c446f82

collects/framework/private/main.ss

@@ -1,332 +1,333 @@
 #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^
-          [prefix preferences: framework:preferences^]
-          [prefix exit: framework:exit^]
-          [prefix group: framework:group^]
-          [prefix handler: framework:handler^]
-          [prefix editor: framework:editor^]
-          [prefix color-prefs: framework:color-prefs^]
-          [prefix scheme: framework:scheme^])
-  (export framework:main^)
-  (init-depend framework:preferences^ framework:exit^ framework:editor^
-               framework:color-prefs^ framework:scheme^)
-  
-  (preferences:low-level-put-preferences preferences:put-preferences/gui)
-  
-  (application-preferences-handler (λ () (preferences:show-dialog)))
-  
-  (preferences:set-default 'framework:replace-visible? #f boolean?)
-  (preferences:set-default 'framework:anchored-search #f boolean?)
-  
-  (let ([search/replace-string-predicate
-         (λ (l) 
-           (and (list? l)
-                (andmap 
-                 (λ (x) (or (string? x) (is-a? x snip%)))
-                 l)))])
-    (preferences:set-default 'framework:search-string 
-                             '() 
-                             search/replace-string-predicate)
-    (preferences:set-default 'framework:replace-string 
-                             '() 
-                             search/replace-string-predicate))
-  
-  ;; marshalling for this one will just lose information. Too bad.
-  (preferences:set-un/marshall 'framework:search-string 
-                               (λ (l)
-                                 (map (λ (x) 
-                                        (if (is-a? x snip%)
-                                            (send x get-text 0 (send x get-count))
-                                            x))
-                                      l))
-                               values)
-                               
-  (preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?)
-  
-  (preferences:set-default 'framework:square-bracket:cond/offset
-                           '(("case-lambda" 0)
-                             ("cond" 0)
-                             ("field" 0)
-                             ("provide/contract" 0)
-                             ("new" 1)
-                             ("case" 1)
-                             ("syntax-case" 2)
-                             ("syntax-case*" 3))
-                           (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
-                                                                     (string? (car x))
-                                                                     (pair? (cdr x))
-                                                                     (number? (cadr x))
-                                                                     (null? (cddr x))))
-                                                         x))))
-  (preferences:set-default 'framework:square-bracket:local
-                           '("local")
-                           (λ (x) (and (list? x) (andmap string? x))))
-  (preferences:set-default 'framework:square-bracket:letrec
-                           '("let" 
-                             "let*" "let-values" "let*-values"
-                             "let-syntax" "let-struct" "let-syntaxes"
-                             "letrec"
-                             "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
-                             "parameterize"
-                             "with-syntax")
-                           (λ (x) (and (list? x) (andmap string? x))))
-  
-  (preferences:set-default 'framework:white-on-black? #f boolean?)
-  
-  (preferences:set-default 'framework:case-sensitive-search?
-                           #f
-                           boolean?)
-  (color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
-  
-  (preferences:set-default 'framework:special-meta-key #f boolean?)
-  (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))
-  
-  (preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
-  
-  (preferences:set-default 'framework:standard-style-list:font-name
-                           (get-family-builtin-face 'modern)
-                           string?)
-  
-  (preferences:set-default
-   'framework:standard-style-list:font-size
-   (let* ([txt (make-object text%)]
-          [stl (send txt get-style-list)]
-          [bcs (send stl basic-style)])
-     (send bcs get-size))
-   (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
-  
-  (preferences:set-default
-   'framework:standard-style-list:smoothing
-   'default
-   (λ (x) 
-     (memq x '(unsmoothed partly-smoothed smoothed default))))
-  
-  (editor:set-standard-style-list-pref-callbacks)
-  
-  (color-prefs:set-default/color-scheme
-   'framework:paren-match-color
-   (let ([gray-level
-          ;; old gray-level 192
-          (if (eq? (system-type) 'windows)
-              (* 3/4 256)
-              (- (* 7/8 256) 1))])
-     (make-object color% gray-level gray-level gray-level))
-   (make-object color% 50 50 50))
-  
-  (preferences:set-default 'framework:recently-opened-files/pos 
-                           null 
-                           (λ (x) (and (list? x) 
-                                       (andmap
-                                        (λ (x) 
-                                          (and (list? x)
-                                               (= 3 (length x))
-                                               (path? (car x))
-                                               (number? (cadr x))
-                                               (number? (caddr x))))
-                                        x))))
-  
-  (preferences:set-un/marshall
-   'framework:recently-opened-files/pos
-   (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
-   (λ (l) 
-     (let/ec k
-       (unless (list? l)
-         (k '()))
-       (map (λ (x)
-              (unless (and (list? x)
-                           (= 3 (length x))
-                           (bytes? (car x))
-                           (number? (cadr x))
-                           (number? (caddr x)))
-                (k '()))
-              (cons (bytes->path (car x)) (cdr x)))
-            l))))
-  
-  (preferences:set-default 'framework:last-directory 
-                           (find-system-path 'doc-dir) 
-                           (λ (x) (or (not x) path-string?)))
-  
-  (preferences:set-un/marshall 'framework:last-directory 
-                               (λ (x) (and (path? x) (path->bytes x)))
-                               (λ (x)
-                                 (and (bytes? x)
-                                      (bytes->path x))))
-  
-  (preferences:set-default 'framework:recent-max-count 
-                           50 
-                           (λ (x) (and (number? x)
-                                       (x . > . 0) 
-                                       (integer? x))))
-  (preferences:add-callback
-   'framework:recent-max-count
-   (λ (p v)
-     (handler:size-recently-opened-files v)))
-  
-  (preferences:set-default 'framework:last-url-string "" string?)
-  (preferences:set-default 'framework:recently-opened-sort-by 'age 
-                           (λ (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-h 600 number?)
-  (preferences:set-default 'framework:open-here? #f boolean?)
-  (preferences:set-default 'framework:show-delegate? #f boolean?)
-  (preferences:set-default 'framework:windows-mdi #f boolean?)
-  (preferences:set-default 'framework:menu-bindings #t boolean?)
-  (preferences:set-default 'framework:verify-change-format #f boolean?)
-  (preferences:set-default 'framework:auto-set-wrap? #t boolean?)
-  (preferences:set-default 'framework:display-line-numbers #t boolean?)
-  (preferences:set-default 'framework:show-status-line #t boolean?)
-  (preferences:set-default 'framework:col-offsets #f boolean?)
-  
-  (preferences:set-default
-   'framework:print-output-mode
-   'standard
-   (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
-  
-  (preferences:set-default 'framework:highlight-parens #t boolean?)
-  (preferences:set-default 'framework:fixup-parens #t boolean?)
-  (preferences:set-default 'framework:fixup-open-parens #t boolean?)
-  (preferences:set-default 'framework:paren-match #t boolean?)
-  (let ([hash-table (make-hasheq)])
-    (for-each (λ (x) 
-                (hash-set! hash-table x 'define))
-              '(local))
-    (for-each (λ (x) 
-                (hash-set! hash-table x 'begin))
-              '(case-lambda
-                 match-lambda match-lambda*
-                 cond
-                 delay
-                 unit compound-unit compound-unit/sig
-                 public private override
-                 inherit sequence))
-    (for-each (λ (x) 
-                (hash-set! hash-table x 'lambda))
-              '(
-                cases
-                   instantiate super-instantiate
-                 syntax/loc quasisyntax/loc
-                 
-                 
-                 λ lambda let let* letrec recur
-                 lambda/kw
-                 letrec-values
-                 with-syntax
-                 with-continuation-mark
-                 module
-                 match match-let match-let* match-letrec
-                 let/cc let/ec letcc catch
-                 let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
 
-                 for for/list for/hash for/hasheq for/and for/or 
+(import mred^
-                 for/lists for/first for/last for/fold
+        [prefix preferences: framework:preferences^]
-                 for* for*/list for*/hash for*/hasheq for*/and for*/or 
+        [prefix exit: framework:exit^]
-                 for*/lists for*/first for*/last for*/fold                 
+        [prefix group: framework:group^]
-                 
+        [prefix handler: framework:handler^]
-                 kernel-syntax-case
+        [prefix editor: framework:editor^]
-                 syntax-case syntax-case* syntax-rules syntax-id-rules
+        [prefix color-prefs: framework:color-prefs^]
-                 let-signature fluid-let
+        [prefix scheme: framework:scheme^])
-                 let-struct let-macro let-values let*-values
+(export framework:main^)
-                 case when unless 
+(init-depend framework:preferences^ framework:exit^ framework:editor^
-                 let-enumerate
+             framework:color-prefs^ framework:scheme^)
-                 class class* class-asi class-asi* class*/names
+
-                 class100 class100* class100-asi class100-asi* class100*/names
+(preferences:low-level-put-preferences preferences:put-preferences/gui)
-                 rec
+
-                 make-object mixin
+(application-preferences-handler (λ () (preferences:show-dialog)))
-                 define-some do opt-lambda
+
-                 send* with-method
+(preferences:set-default 'framework:ask-about-paste-normalization #t boolean?)
-                 define-record
+(preferences:set-default 'framework:do-paste-normalization #t boolean?)
-                 catch shared
+
-                 unit/sig unit/lang
+(preferences:set-default 'framework:replace-visible? #f boolean?)
-                 with-handlers
+(preferences:set-default 'framework:anchored-search #f boolean?)
-                 interface
+
-                 parameterize
+(let ([search/replace-string-predicate
-                 call-with-input-file call-with-input-file* with-input-from-file
+       (λ (l) 
-                 with-input-from-port call-with-output-file
+         (and (list? l)
-                 with-output-to-file with-output-to-port))
+              (andmap 
-    (preferences:set-default 
+               (λ (x) (or (string? x) (is-a? x snip%)))
-     'framework:tabify
+               l)))])
-     (list hash-table #rx"^begin" #rx"^def" #f)
+  (preferences:set-default 'framework:search-string 
-     (λ (x)
+                           '() 
-       (and (list? x)
+                           search/replace-string-predicate)
-            (= (length x) 4)
+  (preferences:set-default 'framework:replace-string 
-            (hash? (car x))
+                           '() 
-            (andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
+                           search/replace-string-predicate))
-    (preferences:set-un/marshall
+
-     'framework:tabify 
+;; marshalling for this one will just lose information. Too bad.
-     (λ (t) (cons (hash-map (car t) list)
+(preferences:set-un/marshall 'framework:search-string 
-                  (cdr t)))
+                             (λ (l)
-     (λ (l) 
+                               (map (λ (x) 
-       (and (list? l)
+                                      (if (is-a? x snip%)
-            (= (length l) 4)
+                                          (send x get-text 0 (send x get-count))
-            (andmap (λ (x) (or (regexp? x) (not x)))
+                                          x))
-                    (cdr l))
+                                    l))
-            (andmap (λ (x) (and (list? x)
+                             values)
-                                (= 2 (length x))
+
-                                (andmap symbol? x)))
+(preferences:set-default 'framework:paren-color-scheme 'basic-grey symbol?)
-                    (car l))
+
-            (let ([h (make-hasheq)])
+(preferences:set-default 'framework:square-bracket:cond/offset
-              (for-each (λ (x) (apply hash-set! h x)) (car l))
+                         '(("case-lambda" 0)
-              (cons h (cdr l)))))))
+                           ("cond" 0)
-  
+                           ("field" 0)
-  
+                           ("provide/contract" 0)
-  (preferences:set-default 'framework:autosave-delay 300 number?)
+                           ("new" 1)
-  (preferences:set-default 'framework:autosaving-on? #t boolean?)
+                           ("case" 1)
-  (preferences:set-default 'framework:backup-files? #t boolean?)
+                           ("syntax-case" 2)
-  (preferences:set-default 'framework:verify-exit #t boolean?)
+                           ("syntax-case*" 3))
-  (preferences:set-default 'framework:delete-forward? #t boolean?)
+                         (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x)
-  (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
+                                                                   (string? (car x))
-  (preferences:set-default 'framework:file-dialogs 'std
+                                                                   (pair? (cdr x))
-                           (λ (x) (and (memq x '(common std)) #t)))
+                                                                   (number? (cadr x))
-  
+                                                                   (null? (cddr x))))
-  ;; scheme prefs
+                                                       x))))
-  
+(preferences:set-default 'framework:square-bracket:local
-  (for-each (λ (line white-on-black-line)
+                         '("local")
-              (let ([sym (car line)]
+                         (λ (x) (and (list? x) (andmap string? x))))
-                    [color (cadr line)]
+(preferences:set-default 'framework:square-bracket:letrec
-                    [white-on-black-color (cadr white-on-black-line)])
+                         '("let" 
-                (color-prefs:register-color-preference
+                           "let*" "let-values" "let*-values"
-                 (scheme:short-sym->pref-name sym)
+                           "let-syntax" "let-struct" "let-syntaxes"
-                 (scheme:short-sym->style-name sym)
+                           "letrec"
-                 color
+                           "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values"
-                 white-on-black-color)))
+                           "parameterize"
-            (scheme:get-color-prefs-table)
+                           "with-syntax")
-            (scheme:get-white-on-black-color-prefs-table))
+                         (λ (x) (and (list? x) (andmap string? x))))
-  (preferences:set-default 'framework:coloring-active #t boolean?)
+
-  
+(preferences:set-default 'framework:white-on-black? #f boolean?)
-  (color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
+
-  (preferences:add-callback 'framework:default-text-color
+(preferences:set-default 'framework:case-sensitive-search?
-                            (λ (p v)
+                         #f
-                              (editor:set-default-font-color v)))
+                         boolean?)
-  (editor:set-default-font-color (preferences:get 'framework:default-text-color))
+(color-prefs:set-default/color-scheme 'framework:basic-canvas-background "white" "black")
-  
+
-  (color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
+(preferences:set-default 'framework:special-meta-key #f boolean?)
-                                        "light blue"
+(preferences:add-callback 'framework:special-meta-key (λ (p v) (map-command-as-meta-key v)))
-                                        (make-object color% 62 67 155))
+(map-command-as-meta-key (preferences:get 'framework:special-meta-key))
-  
+
-  
+(preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
-  ;; groups
+
-  
+(preferences:set-default 'framework:standard-style-list:font-name
-  (preferences:set-default 'framework:exit-when-no-frames #t boolean?)
+                         (get-family-builtin-face 'modern)
-  (unless (preferences:get 'framework:exit-when-no-frames)
+                         string?)
-    (preferences:set 'framework:exit-when-no-frames #t))
+
-  
+(preferences:set-default
-  (exit:insert-can?-callback
+ 'framework:standard-style-list:font-size
-   (λ ()
+ (let* ([txt (make-object text%)]
-     (send (group:get-the-frame-group) can-close-all?)))    
+        [stl (send txt get-style-list)]
-  
+        [bcs (send stl basic-style)])
-  (exit:insert-on-callback
+   (send bcs get-size))
-   (λ ()
+ (λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
-     (send (group:get-the-frame-group) on-close-all)))
+
-  
+(preferences:set-default
-  ;; reset these -- they are only for the test suite.
+ 'framework:standard-style-list:smoothing
-  ;; they do not need to be set across starting up and shutting down
+ 'default
-  ;; the application.
+ (λ (x) 
-  ;(preferences:set 'framework:file-dialogs 'std)
+   (memq x '(unsmoothed partly-smoothed smoothed default))))
-  
+
-  ;; setup the color scheme stuff
+(editor:set-standard-style-list-pref-callbacks)
+
+(color-prefs:set-default/color-scheme
+ 'framework:paren-match-color
+ (let ([gray-level
+        ;; old gray-level 192
+        (if (eq? (system-type) 'windows)
+            (* 3/4 256)
+            (- (* 7/8 256) 1))])
+   (make-object color% gray-level gray-level gray-level))
+ (make-object color% 50 50 50))
+
+(preferences:set-default 'framework:recently-opened-files/pos 
+                         null 
+                         (λ (x) (and (list? x) 
+                                     (andmap
+                                      (λ (x) 
+                                        (and (list? x)
+                                             (= 3 (length x))
+                                             (path? (car x))
+                                             (number? (cadr x))
+                                             (number? (caddr x))))
+                                      x))))
+
+(preferences:set-un/marshall
+ 'framework:recently-opened-files/pos
+ (λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
+ (λ (l) 
+   (let/ec k
+     (unless (list? l)
+       (k '()))
+     (map (λ (x)
+            (unless (and (list? x)
+                         (= 3 (length x))
+                         (bytes? (car x))
+                         (number? (cadr x))
+                         (number? (caddr x)))
+              (k '()))
+            (cons (bytes->path (car x)) (cdr x)))
+          l))))
+
+(preferences:set-default 'framework:last-directory 
+                         (find-system-path 'doc-dir) 
+                         (λ (x) (or (not x) path-string?)))
+
+(preferences:set-un/marshall 'framework:last-directory 
+                             (λ (x) (and (path? x) (path->bytes x)))
+                             (λ (x)
+                               (and (bytes? x)
+                                    (bytes->path x))))
+
+(preferences:set-default 'framework:recent-max-count 
+                         50 
+                         (λ (x) (and (number? x)
+                                     (x . > . 0) 
+                                     (integer? x))))
+(preferences:add-callback
+ 'framework:recent-max-count
+ (λ (p v)
+   (handler:size-recently-opened-files v)))
+
+(preferences:set-default 'framework:last-url-string "" string?)
+(preferences:set-default 'framework:recently-opened-sort-by 'age 
+                         (λ (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-h 600 number?)
+(preferences:set-default 'framework:open-here? #f boolean?)
+(preferences:set-default 'framework:show-delegate? #f boolean?)
+(preferences:set-default 'framework:windows-mdi #f boolean?)
+(preferences:set-default 'framework:menu-bindings #t boolean?)
+(preferences:set-default 'framework:verify-change-format #f boolean?)
+(preferences:set-default 'framework:auto-set-wrap? #t boolean?)
+(preferences:set-default 'framework:display-line-numbers #t boolean?)
+(preferences:set-default 'framework:show-status-line #t boolean?)
+(preferences:set-default 'framework:col-offsets #f boolean?)
+
+(preferences:set-default
+ 'framework:print-output-mode
+ 'standard
+ (λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
+
+(preferences:set-default 'framework:highlight-parens #t boolean?)
+(preferences:set-default 'framework:fixup-parens #t boolean?)
+(preferences:set-default 'framework:fixup-open-parens #t boolean?)
+(preferences:set-default 'framework:paren-match #t boolean?)
+(let ([hash-table (make-hasheq)])
+  (for-each (λ (x) 
+              (hash-set! hash-table x 'define))
+            '(local))
+  (for-each (λ (x) 
+              (hash-set! hash-table x 'begin))
+            '(case-lambda
+               match-lambda match-lambda*
+               cond
+               delay
+               unit compound-unit compound-unit/sig
+               public private override
+               inherit sequence))
+  (for-each (λ (x) 
+              (hash-set! hash-table x 'lambda))
+            '(
+              cases
+                 instantiate super-instantiate
+               syntax/loc quasisyntax/loc
+               
+               
+               λ lambda let let* letrec recur
+               lambda/kw
+               letrec-values
+               with-syntax
+               with-continuation-mark
+               module
+               match match-let match-let* match-letrec
+               let/cc let/ec letcc catch
+               let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
+               
+               for for/list for/hash for/hasheq for/and for/or 
+               for/lists for/first for/last for/fold
+               for* for*/list for*/hash for*/hasheq for*/and for*/or 
+               for*/lists for*/first for*/last for*/fold                 
+               
+               kernel-syntax-case
+               syntax-case syntax-case* syntax-rules syntax-id-rules
+               let-signature fluid-let
+               let-struct let-macro let-values let*-values
+               case when unless 
+               let-enumerate
+               class class* class-asi class-asi* class*/names
+               class100 class100* class100-asi class100-asi* class100*/names
+               rec
+               make-object mixin
+               define-some do opt-lambda
+               send* with-method
+               define-record
+               catch shared
+               unit/sig unit/lang
+               with-handlers
+               interface
+               parameterize
+               call-with-input-file call-with-input-file* with-input-from-file
+               with-input-from-port call-with-output-file
+               with-output-to-file with-output-to-port))
+  (preferences:set-default 
+   'framework:tabify
+   (list hash-table #rx"^begin" #rx"^def" #f)
+   (λ (x)
+     (and (list? x)
+          (= (length x) 4)
+          (hash? (car x))
+          (andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
+  (preferences:set-un/marshall
+   'framework:tabify 
+   (λ (t) (cons (hash-map (car t) list)
+                (cdr t)))
+   (λ (l) 
+     (and (list? l)
+          (= (length l) 4)
+          (andmap (λ (x) (or (regexp? x) (not x)))
+                  (cdr l))
+          (andmap (λ (x) (and (list? x)
+                              (= 2 (length x))
+                              (andmap symbol? x)))
+                  (car l))
+          (let ([h (make-hasheq)])
+            (for-each (λ (x) (apply hash-set! h x)) (car l))
+            (cons h (cdr l)))))))
+
+
+(preferences:set-default 'framework:autosave-delay 300 number?)
+(preferences:set-default 'framework:autosaving-on? #t boolean?)
+(preferences:set-default 'framework:backup-files? #t boolean?)
+(preferences:set-default 'framework:verify-exit #t boolean?)
+(preferences:set-default 'framework:delete-forward? #t boolean?)
+(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
+(preferences:set-default 'framework:file-dialogs 'std
+                         (λ (x) (and (memq x '(common std)) #t)))
+
+;; scheme prefs
+
+(for-each (λ (line white-on-black-line)
+            (let ([sym (car line)]
+                  [color (cadr line)]
+                  [white-on-black-color (cadr white-on-black-line)])
+              (color-prefs:register-color-preference
+               (scheme:short-sym->pref-name sym)
+               (scheme:short-sym->style-name sym)
+               color
+               white-on-black-color)))
+          (scheme:get-color-prefs-table)
+          (scheme:get-white-on-black-color-prefs-table))
+(preferences:set-default 'framework:coloring-active #t boolean?)
+
+(color-prefs:set-default/color-scheme 'framework:default-text-color "black" "white")
+(preferences:add-callback 'framework:default-text-color
+                          (λ (p v)
+                            (editor:set-default-font-color v)))
+(editor:set-default-font-color (preferences:get 'framework:default-text-color))
+
+(color-prefs:set-default/color-scheme 'framework:delegatee-overview-color
+                                      "light blue"
+                                      (make-object color% 62 67 155))
+
+
+;; groups
+
+(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
+(unless (preferences:get 'framework:exit-when-no-frames)
+  (preferences:set 'framework:exit-when-no-frames #t))
+
+(exit:insert-can?-callback
+ (λ ()
+   (send (group:get-the-frame-group) can-close-all?)))    
+
+(exit:insert-on-callback
+ (λ ()
+   (send (group:get-the-frame-group) on-close-all)))
+
+;; reset these -- they are only for the test suite.
+;; they do not need to be set across starting up and shutting down
+;; the application.
+;(preferences:set 'framework:file-dialogs 'std)

collects/framework/private/preferences.ss

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

collects/framework/private/sig.ss

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

collects/framework/private/text.ss

@@ -821,7 +821,83 @@ WARNING: printf is rebound in the body of the unit to always
         (set! rewriting #f))
       (end-edit-sequence)
       (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<%> 
   (interface (editor:keymap<%> basic<%>)
@@ -3644,6 +3720,7 @@ designates the character that triggers autocompletion
 (define basic% (basic-mixin (editor:basic-mixin text%)))
 (define hide-caret/selection% (hide-caret/selection-mixin basic%))
 (define nbsp->space% (nbsp->space-mixin basic%))
+(define normalize-paste% (normalize-paste-mixin basic%))
 (define delegate% (delegate-mixin basic%))
 (define wide-snip% (wide-snip-mixin basic%))
 (define standard-style-list% (editor:standard-style-list-mixin wide-snip%))

collects/scribblings/framework/text.scrbl

@@ -302,6 +302,33 @@
     @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<%>)]{
   Any object matching this interface can be searched.