1  #lang racket
  2  (require racket/unit
  3           mred/mred-sig
  4           string-constants
  5           "text-sig.rkt"
  6           "../preferences.rkt")
  7  
  8  (provide text-normalize-paste@ as-a-paste)
  9  
 10  (define-local-member-name as-a-paste)
 11  
 12  (define-unit text-normalize-paste@
 13    (import mred^
 14            text-basic^)
 15    (export text-normalize-paste^)
 16  
 17    (define normalize-paste<%> (interface ((class->interface text%))
 18                                 ask-normalize?
 19                                 string-normalize))
 20    (define normalize-paste-mixin
 21      (mixin (basic<%>) (normalize-paste<%>)
 22        (inherit begin-edit-sequence end-edit-sequence
 23                 delete insert split-snip find-snip
 24                 get-snip-position get-top-level-window find-string)
 25      
 26        ;; pasting-info : (or/c #f (listof (list number number)))
 27        ;; when #f, we are not in a paste
 28        ;; when a list, we are in a paste and the 
 29        ;;   list contains the regions that have
 30        ;;   been changed by the paste
 31        (define paste-info #f)
 32  
 33        (define/public (ask-normalize?)
 34          (cond
 35            [(preferences:get 'framework:ask-about-paste-normalization)
 36             (define-values (mbr checked?)
 37               (message+check-box/custom
 38                (string-constant drscheme)
 39                (string-constant normalize-string-info)
 40                (string-constant dont-ask-again)
 41                (string-constant normalize)
 42                (string-constant leave-alone)
 43                #f
 44                (get-top-level-window)
 45                (cons (if (preferences:get 'framework:do-paste-normalization)
 46                          'default=1
 47                          'default=2)
 48                      '(caution))
 49                2))
 50             (define normalize? (not (equal? 2 mbr)))
 51             (preferences:set 'framework:ask-about-paste-normalization (not checked?))
 52             (preferences:set 'framework:do-paste-normalization normalize?)
 53             normalize?]
 54            [else
 55             (preferences:get 'framework:do-paste-normalization)]))
 56        (define/public (string-normalize s) 
 57          (regexp-replace* 
 58           #rx"\u200b" 
 59           (regexp-replace*
 60            #rx"\u2212" 
 61            (string-normalize-nfkc s)
 62            "-")
 63           ""))
 64  
 65        ;; method for use in the test suites
 66        (define/public-final (as-a-paste thunk)
 67          (dynamic-wind
 68           (λ () (set! paste-info '()))
 69           (λ ()
 70             (thunk)
 71             (define local-paste-info paste-info)
 72             (set! paste-info #f)
 73             (deal-with-paste local-paste-info))
 74           ;; use the dynamic wind to be sure that the paste-info is set back to #f
 75           ;; in the case that the middle thunk raises an exception
 76           (λ () (set! paste-info #f))))
 77      
 78        (define/override (do-paste start the-time)
 79          (as-a-paste (λ () (super do-paste start the-time))))
 80      
 81        (define/augment (after-insert start len)
 82          (when paste-info
 83            (set! paste-info (cons (list start len) paste-info)))
 84          (inner (void) after-insert start len))
 85  
 86        (define/private (deal-with-paste local-paste-info)
 87          (let/ec abort
 88            (define ask? #t)
 89            (for ([insertion (in-list local-paste-info)])
 90              (define start (list-ref insertion 0))
 91              (define len (list-ref insertion 1))
 92              (split-snip start)
 93              (split-snip (+ start len))
 94              (define changes-to-make '())
 95              (let loop ([snip (find-snip (+ start len) 'before-or-none)])
 96                (when snip
 97                  (define prev-snip (send snip previous))
 98                  (define pos (get-snip-position snip))
 99                  (when (pos . >= . start)
100                    (when (is-a? snip string-snip%)
101                      (define old (send snip get-text 0 (send snip get-count)))
102                      (define new (string-normalize old))
103                      (unless (equal? new old)
104                        (when ask?
105                          (set! ask? #f)
106                          (unless (ask-normalize?) (abort)))
107                        (define snip-pos (get-snip-position snip))
108                        (set! changes-to-make
109                              (cons (λ ()
110                                      (delete snip-pos (+ snip-pos (string-length old)))
111                                      (insert new snip-pos snip-pos #f))
112                                    changes-to-make))))
113                    (loop prev-snip))))
114              (for ([change (in-list (reverse changes-to-make))])
115                (change)))))
116  
117        (super-new))))