diff --git a/gui-lib/framework/private/editor.rkt b/gui-lib/framework/private/editor.rkt index 8c886371..baeb68fa 100644 --- a/gui-lib/framework/private/editor.rkt +++ b/gui-lib/framework/private/editor.rkt @@ -5,6 +5,7 @@ "sig.rkt" "../preferences.rkt" "../gui-utils.rkt" + "interfaces.rkt" mzlib/etc mred/mred-sig racket/path) @@ -26,22 +27,7 @@ ;; renaming, for editor-mixin where get-file is shadowed by a method. (define mred:get-file get-file) - (define basic<%> - (interface (editor<%>) - has-focus? - local-edit-sequence? - run-after-edit-sequence - get-top-level-window - save-file-out-of-date? - save-file/gui-error - load-file/gui-error - on-close - can-close? - close - get-filename/untitled-name - - get-pos/text - get-pos/text-dc-location)) + (define basic<%> editor:basic<%>) (define basic-mixin (mixin (editor<%>) (basic<%>) @@ -506,7 +492,7 @@ delta))) (void))) - (define -keymap<%> (interface (basic<%>) get-keymaps)) + (define -keymap<%> editor:keymap<%>) (define keymap-mixin (mixin (basic<%>) (-keymap<%>) (define/public (get-keymaps) diff --git a/gui-lib/framework/private/frame.rkt b/gui-lib/framework/private/frame.rkt index dd95a73d..21ca1047 100644 --- a/gui-lib/framework/private/frame.rkt +++ b/gui-lib/framework/private/frame.rkt @@ -10,6 +10,7 @@ "../gui-utils.rkt" "bday.rkt" "gen-standard-menus.rkt" + "interfaces.rkt" framework/private/focus-table mrlib/close-icon mred/mred-sig) @@ -132,15 +133,7 @@ (set! frame-width (min frame-width (- w window-trimming-upper-bound-width))) (set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))) -(define basic<%> (interface ((class->interface frame%)) - get-area-container% - get-area-container - get-menu-bar% - make-root-area-container - close - editing-this-file? - get-filename - make-visible)) +(define basic<%> frame:basic<%>) (define focus-table<%> (interface (top-level-window<%>))) (define focus-table-mixin @@ -741,17 +734,7 @@ (super-new))) -(define info<%> (interface (basic<%>) - determine-width - lock-status-changed - update-info - set-info-canvas - get-info-canvas - get-info-editor - get-info-panel - show-info - hide-info - is-info-hidden?)) +(define info<%> frame:info<%>) (define magic-space 25) @@ -1038,13 +1021,7 @@ (min-client-height (inexact->exact (floor th))))) (update-client-width init-width))) -(define text-info<%> (interface (info<%>) - set-macro-recording - overwrite-status-changed - anchor-status-changed - editor-position-changed - use-file-text-mode-changed - add-line-number-menu-items)) +(define text-info<%> frame:text-info<%>) (define text-info-mixin (mixin (info<%>) (text-info<%>) (inherit get-info-editor) @@ -1343,6 +1320,7 @@ (mixin (basic<%>) (pasteboard-info<%>) (super-new))) +(define standard-menus<%> frame:standard-menus<%>) (generate-standard-menus-code) (define -editor<%> (interface (standard-menus<%>) diff --git a/gui-lib/framework/private/gen-standard-menus.rkt b/gui-lib/framework/private/gen-standard-menus.rkt index 0c75b4e3..4475f9b5 100644 --- a/gui-lib/framework/private/gen-standard-menus.rkt +++ b/gui-lib/framework/private/gen-standard-menus.rkt @@ -101,29 +101,34 @@ `((define/public ,(generic-name generic) ,(generic-initializer generic)))])) -(provide generate-standard-menus-code) +(provide generate-standard-menus-code + generate-standard-menus-interface-code) +(define-syntax (generate-standard-menus-interface-code stx) + (datum->syntax + stx + `(define frame:standard-menus<%> + (interface (frame:basic<%>) + ,@(append-map + (λ (x) + (cond [(an-item? x) + (list (an-item->callback-name x) + (an-item->get-item-name x) + (an-item->string-name x) + (an-item->help-string-name x) + (an-item->on-demand-name x) + (an-item->create-menu-item-name x))] + [(between? x) + (list (between->name x))] + [(or (after? x) (before? x)) + (list (before/after->name x))] + [(generic? x) + (if (generic-method? x) (list (generic-name x)) '())])) + items))))) + (define-syntax (generate-standard-menus-code stx) (datum->syntax stx `(begin - (define standard-menus<%> - (interface (basic<%>) - ,@(append-map - (λ (x) - (cond [(an-item? x) - (list (an-item->callback-name x) - (an-item->get-item-name x) - (an-item->string-name x) - (an-item->help-string-name x) - (an-item->on-demand-name x) - (an-item->create-menu-item-name x))] - [(between? x) - (list (between->name x))] - [(or (after? x) (before? x)) - (list (before/after->name x))] - [(generic? x) - (if (generic-method? x) (list (generic-name x)) '())])) - items))) (define standard-menus-mixin (mixin (basic<%>) (standard-menus<%>) (inherit on-menu-char on-traverse-char) diff --git a/gui-lib/framework/private/interfaces.rkt b/gui-lib/framework/private/interfaces.rkt new file mode 100644 index 00000000..cb702082 --- /dev/null +++ b/gui-lib/framework/private/interfaces.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require racket/class + racket/gui/base + "gen-standard-menus.rkt") + +(provide editor:basic<%> + editor:keymap<%> + text:basic<%> + frame:basic<%> + frame:standard-menus<%> + frame:info<%> + frame:text-info<%>) + +(define editor:basic<%> + (interface (editor<%>) + has-focus? + local-edit-sequence? + run-after-edit-sequence + get-top-level-window + save-file-out-of-date? + save-file/gui-error + load-file/gui-error + on-close + can-close? + close + get-filename/untitled-name + + get-pos/text + get-pos/text-dc-location)) + +(define editor:keymap<%> + (interface (editor:basic<%>) + get-keymaps)) + +(define text:basic<%> + (interface (editor:basic<%> (class->interface text%)) + highlight-range + unhighlight-range + unhighlight-ranges + unhighlight-ranges/key + get-highlighted-ranges + get-styles-fixed + get-fixed-style + set-styles-fixed + move/copy-to-edit + initial-autowrap-bitmap + get-port-name + port-name-matches? + after-set-port-unsaved-name + set-port-unsaved-name + get-start-of-line)) + +(define frame:basic<%> + (interface ((class->interface frame%)) + get-area-container% + get-area-container + get-menu-bar% + make-root-area-container + close + editing-this-file? + get-filename + make-visible)) + +(generate-standard-menus-interface-code) + +(define frame:info<%> + (interface (frame:basic<%>) + determine-width + lock-status-changed + update-info + set-info-canvas + get-info-canvas + get-info-editor + get-info-panel + show-info + hide-info + is-info-hidden?)) + +(define frame:text-info<%> + (interface (frame:info<%>) + set-macro-recording + overwrite-status-changed + anchor-status-changed + editor-position-changed + use-file-text-mode-changed + add-line-number-menu-items)) \ No newline at end of file diff --git a/gui-lib/framework/private/keymap-global.rkt b/gui-lib/framework/private/keymap-global.rkt new file mode 100644 index 00000000..ac992993 --- /dev/null +++ b/gui-lib/framework/private/keymap-global.rkt @@ -0,0 +1,1364 @@ +#lang racket/base +(require racket/gui/base + racket/class + mrlib/tex-table + "interfaces.rkt" + "../preferences.rkt" + "gen-standard-menus.rkt" + (only-in srfi/13 string-prefix? string-prefix-length) + unstable/2d/dir-chars + racket/list) + +(provide has-control-regexp + keymap:region-click + keymap:make-meta-prefix-list + keymap:send-map-function-meta + keymap:setup-global + keymap:add-to-right-button-menu + keymap:add-to-right-button-menu/before) + +(define keymap:add-to-right-button-menu (make-parameter void)) +(define keymap:add-to-right-button-menu/before (make-parameter void)) + +(define has-control-regexp #rx"(?:^|:)c:") + +(define (keymap:make-meta-prefix-list key [mask-control? #f]) + ;; Note: key canonicalization will remove "~g" when redundant + (list (if mask-control? + (string-append "~g:m:" key) + (string-append "~c:~g:m:" key)) + (string-append "ESC;" key))) + +(define (keymap:send-map-function-meta keymap key func [mask-control? #f] + #:alt-as-meta-keymap [alt-as-meta-keymap #f]) + (for ([key (in-list (keymap:make-meta-prefix-list key mask-control?))]) + (send keymap map-function key func)) + (when alt-as-meta-keymap + (unless (send alt-as-meta-keymap is-function-added? func) + (error 'keymap:send-map-function-meta + "expected to find ~s mapped in alt-as-meta-keymap" + func)) + (send alt-as-meta-keymap map-function (string-append "?:a:" key) func))) + +(define keymap:setup-global + ; Define some useful keyboard functions + (let* ([ring-bell + (λ (edit event) + (bell))] + + [mouse-popup-menu + (λ (edit event) + (when (send event button-up?) + (let ([a (send edit get-admin)]) + (when a + (let ([m (make-object popup-menu%)]) + + ((keymap:add-to-right-button-menu/before) m edit event) + + (append-editor-operation-menu-items + m #:popup-position + (list edit + (send edit find-position (send event get-x) (send event get-y)))) + (for-each + (λ (i) + (when (is-a? i selectable-menu-item<%>) + (send i set-shortcut #f))) + (send m get-items)) + + ((keymap:add-to-right-button-menu) m edit event) + + (let-values ([(x y) (send edit + dc-location-to-editor-location + (send event get-x) + (send event get-y))]) + (send a popup-menu m (+ x 1) (+ y 1))))))))] + + [toggle-anchor + (λ (edit event) + (send edit set-anchor + (not (send edit get-anchor))))] + [center-view-on-line + (λ (edit event) + (let ([new-mid-line (send edit position-line + (send edit get-start-position))] + [bt (box 0)] + [bb (box 0)]) + (send edit get-visible-line-range bt bb #f) + (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] + [last-pos (send edit position-line (send edit last-position))] + [top-pos (send edit line-start-position + (max (min (- new-mid-line half) last-pos) 0))] + [bottom-pos (send edit line-start-position + (max 0 + (min (+ new-mid-line half) + last-pos)))]) + (send edit scroll-to-position + top-pos + #f + bottom-pos))) + #t)] + + + [collapse-variable-space + ;; As per emacs: collapse tabs & spaces around the point, + ;; perhaps leaving a single space. + ;; drscheme bonus: if at end-of-line, collapse into the next line. + (λ (leave-one? edit event) + (letrec ([last-pos (send edit last-position)] + [sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)] + [collapsible? (λ (c) (and (char-whitespace? c) + (not (char=? #\newline c))))] + [find-noncollapsible + ; Return index of next non-collapsible char, + ; starting at pos in direction dir. + ; NB returns -1 or last-pos, if examining + ; initial/final whitespace + ; (or, when initial pos is outside of [0,last-pos).) + (λ (pos dir) + (let loop ([pos pos]) + (cond [(< pos 0) -1] + [(>= pos last-pos) last-pos] + [(collapsible? (send edit get-character pos)) + (loop (+ pos dir))] + [else pos])))]) + (when (= sel-start sel-end) ; Only when no selection: + (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))] + [end-heeding-eol (find-noncollapsible sel-start +1)] + ; This is the end of the range, were we to always heed newlines. + + ; Special case: if we're sitting at EOL, + ; and we're not affecting much else, + ; then delete that EOL and collapse spaces + ; at the start of next line, too: + [end (if (and (<= (- end-heeding-eol start) + (if leave-one? 1 0)) + (char=? #\newline (send edit get-character end-heeding-eol)) + ; If you wish to avoid deleting an newline at EOF, do so here. + ) + (find-noncollapsible (add1 end-heeding-eol) +1) + end-heeding-eol)] + [making-no-difference? + ; Don't introduce edits into undo-chain, if no effect. + (if leave-one? + (and (= (- end start) 1) + (char=? #\space (send edit get-character start))) + (= (- end start) 0))]) + (unless making-no-difference? + (send edit begin-edit-sequence) + (send edit set-position end) ; Even after delete, caret will be at "end". + (send edit delete start end) + (when leave-one? (send edit insert #\space start)) + (send edit end-edit-sequence))))))] + + [collapse-space + (λ (edit event) + (collapse-variable-space #t edit event))] + + [remove-space + (λ (edit event) + (collapse-variable-space #f edit event))] + + [collapse-newline + (λ (edit event) + (define (find-nonwhite pos d offset) + (define done (if (= offset -1) 0 (send edit last-position))) + (let/ec escape + (let loop ([pos pos]) + (cond + [(= pos done) (escape pos)] + [else + (define c (send edit get-character (+ pos offset))) + (cond + [(char=? #\newline c) + (loop (+ pos d)) + (escape pos)] + [(char-whitespace? c) + (loop (+ pos d))] + [else pos])])))) + (define sel-start (send edit get-start-position)) + (define sel-end (send edit get-end-position)) + (when (= sel-start sel-end) + (define pos-para (send edit position-paragraph sel-start #f)) + (define pos-para-start (send edit paragraph-start-position pos-para)) + (define pos-para-end (send edit paragraph-end-position pos-para)) + + (define whitepara? + (let loop ([pos pos-para-start]) + (if (>= pos pos-para-end) + #t + (and (char-whitespace? (send edit get-character pos)) + (loop (add1 pos)))))) + + (define start (find-nonwhite pos-para-start -1 -1)) + (define end (find-nonwhite pos-para-end 1 0)) + + (define start-para (send edit position-paragraph start #f)) + (define start-para-start (send edit paragraph-start-position start-para)) + (define end-para (send edit position-paragraph end #f)) + (define end-para-start (send edit paragraph-start-position (add1 end-para))) + (cond + [(and whitepara? + (= start-para pos-para) + (= end-para pos-para)) + ; Special case: just delete this para + (send edit delete pos-para-start (add1 pos-para-end))] + [(and whitepara? (< start-para pos-para)) + ; Can delete before & after + (send* edit + (begin-edit-sequence) + (delete (add1 pos-para-end) end-para-start) + (delete start-para-start pos-para-start) + (end-edit-sequence))] + [else + ; Only delete after + (send edit delete (add1 pos-para-end) end-para-start)])))] + + [open-line + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (= sel-start sel-end) + (send* edit + (insert #\newline) + (set-position sel-start)))))] + + [transpose-chars + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (and (= sel-start sel-end) + (not (= sel-start 0))) + + (let ([sel-start + (if (= sel-start + (send edit line-end-position + (send edit position-line sel-start))) + (sub1 sel-start) + sel-start)]) + (let ([s (send edit get-text + sel-start (add1 sel-start))]) + (send* edit + (begin-edit-sequence) + (delete sel-start (add1 sel-start)) + (insert s (- sel-start 1)) + (set-position (add1 sel-start)) + (end-edit-sequence)))))))] + + [transpose-words + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (when (= sel-start sel-end) + (let ([word-1-start (box sel-start)]) + (send edit find-wordbreak word-1-start #f 'caret) + (let ([word-1-end (box (unbox word-1-start))]) + (send edit find-wordbreak #f word-1-end 'caret) + (let ([word-2-end (box (unbox word-1-end))]) + (send edit find-wordbreak #f word-2-end 'caret) + (let ([word-2-start (box (unbox word-2-end))]) + (send edit find-wordbreak word-2-start #f 'caret) + (let ([text-1 (send edit get-text + (unbox word-1-start) + (unbox word-1-end))] + [text-2 (send edit get-text + (unbox word-2-start) + (unbox word-2-end))]) + (send* edit + (begin-edit-sequence) + (insert text-1 + (unbox word-2-start) + (unbox word-2-end)) + (insert text-2 + (unbox word-1-start) + (unbox word-1-end)) + (set-position (unbox word-2-end)) + (end-edit-sequence))))))))))] + + [capitalize-it + (λ (edit char-case1 char-case2) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)] + [real-end (send edit last-position)]) + (when (= sel-start sel-end) + (let ([word-end (let ([b (box sel-start)]) + (send edit find-wordbreak #f b 'caret) + (min real-end (unbox b)))]) + (send edit begin-edit-sequence) + (let loop ([pos sel-start] + [char-case char-case1]) + (when (< pos word-end) + (let ([c (send edit get-character pos)]) + (cond + [(char-alphabetic? c) + (send edit insert + (list->string + (list (char-case c))) + pos (add1 pos)) + (loop (add1 pos) char-case2)] + [else + (loop (add1 pos) char-case)])))) + (send* edit + (end-edit-sequence) + (set-position word-end))))))] + + [capitalize-word + (λ (edit event) + (capitalize-it edit char-upcase char-downcase))] + [upcase-word + (λ (edit event) + (capitalize-it edit char-upcase char-upcase))] + [downcase-word + (λ (edit event) + (capitalize-it edit char-downcase char-downcase))] + + [kill-word + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (let ([end-box (box sel-end)]) + (send edit find-wordbreak #f end-box 'caret) + (send edit kill 0 sel-start (unbox end-box)))))] + + [backward-kill-word + (λ (edit event) + (let ([sel-start (send edit get-start-position)] + [sel-end (send edit get-end-position)]) + (let ([start-box (box sel-start)]) + (send edit find-wordbreak start-box #f 'caret) + (send edit kill 0 (unbox start-box) sel-end))))] + [copy-click-region + (λ (edit event) + (region-click/internal edit event + (λ (click eol start end) + (send edit flash-on start end) + (send edit copy #f 0 start end))))] + [cut-click-region + (λ (edit event) + (region-click/internal edit event + (λ (click eol start end) + (send edit cut #f 0 start end))))] + [paste-click-region + (λ (edit event) + (region-click/internal edit event + (λ (click eol start end) + (send edit set-position click) + (send edit paste-x-selection 0 click))))] + + [mouse-copy-clipboard + (λ (edit event) + (send edit copy #f (send event get-time-stamp)))] + + [mouse-copy-clipboard/disable-anchor + (λ (edit event) + (send edit set-anchor #f) + (send edit copy #f (send event get-time-stamp)))] + + [mouse-paste-clipboard + (λ (edit event) + (send edit paste (send event get-time-stamp)))] + + [mouse-cut-clipboard + (λ (edit event) + (send edit cut #f (send event get-time-stamp)))] + + [select-click-word + (λ (edit event) + (keymap:region-click edit event + (λ (click eol) + (let ([start-box (box click)] + [end-box (box click)]) + (send edit find-wordbreak + start-box + end-box + 'selection) + (send edit set-position + (unbox start-box) + (unbox end-box))))))] + [select-click-line + (λ (edit event) + (keymap:region-click edit event + (λ (click eol) + (let* ([line (send edit position-line + click eol)] + [start (send edit line-start-position + line #f)] + [end (send edit line-end-position + line #f)]) + (send edit set-position start end)))))] + [repeater + (λ (n edit) + (let* ([km (send edit get-keymap)] + [done + (λ () + (send km set-break-sequence-callback void) + (send km remove-grab-key-function))]) + (send km set-grab-key-function + (λ (name local-km edit event) + (if name + (begin + (done) + (dynamic-wind + (λ () + (send edit begin-edit-sequence)) + (λ () + (let loop ([n n]) + (unless (zero? n) + (send local-km call-function name edit event) + (loop (sub1 n))))) + (λ () + (send edit end-edit-sequence)))) + (let ([k (send event get-key-code)]) + (if (and (char? k) (char<=? #\0 k #\9)) + (set! n (+ (* n 10) (- (char->integer k) + (char->integer #\0)))) + (begin + (done) + (dynamic-wind + (λ () + (send edit begin-edit-sequence)) + (λ () + (let loop ([n n]) + (unless (zero? n) + (send edit on-char event) + (loop (sub1 n))))) + (λ () + (send edit end-edit-sequence))))))) + #t)) + (send km set-break-sequence-callback done) + #t))] + [make-make-repeater + (λ (n) + (λ (edit event) + (repeater n edit)))] + [current-macro '()] + [building-macro #f] [build-macro-km #f] [build-protect? #f] + [show/hide-keyboard-macro-icon + (λ (edit on?) + (when (is-a? edit editor:basic<%>) + (let ([frame (send edit get-top-level-window)]) + (when (is-a? frame frame:text-info<%>) + (send frame set-macro-recording on?) + (send frame update-shown)))))] + + [do-macro + (λ (edit event) + ; If c:x;e during record, copy the old macro + (when building-macro + (set! building-macro (append (reverse current-macro) + (cdr building-macro)))) + (let ([bm building-macro] + [km (send edit get-keymap)]) + (dynamic-wind + (λ () + (set! building-macro #f) + (send edit begin-edit-sequence)) + (λ () + (let/ec escape + (for-each + (λ (f) + (let ([name (car f)] + [event (cdr f)]) + (if name + (unless (send km call-function name edit event #t) + (escape #t)) + (send edit on-char event)))) + current-macro))) + (λ () + (send edit end-edit-sequence) + (set! building-macro bm)))) + #t)] + [start-macro + (λ (edit event) + (if building-macro + (send build-macro-km break-sequence) + (letrec ([km (send edit get-keymap)] + [done + (λ () + (if build-protect? + (send km set-break-sequence-callback done) + (begin + (set! building-macro #f) + (show/hide-keyboard-macro-icon edit #f) + (send km set-break-sequence-callback void) + (send km remove-grab-key-function))))]) + (set! building-macro '()) + (show/hide-keyboard-macro-icon edit #t) + (set! build-macro-km km) + (send km set-grab-key-function + (λ (name local-km edit event) + (dynamic-wind + (λ () + (set! build-protect? #t)) + (λ () + (if name + (send local-km call-function name edit event) + (send edit on-default-char event))) + (λ () + (set! build-protect? #f))) + (when building-macro + (set! building-macro + (cons (cons name event) + building-macro))) + #t)) + (send km set-break-sequence-callback done))) + #t)] + [end-macro + (λ (edit event) + (when building-macro + (set! current-macro (reverse building-macro)) + (set! build-protect? #f) + (send build-macro-km break-sequence)) + #t)] + [delete-key + (λ (edit event) + (let ([kmap (send edit get-keymap)]) + (send kmap call-function + (if (preferences:get 'framework:delete-forward?) + "delete-next-character" + "delete-previous-character") + edit event #t)))] + + [toggle-overwrite + (λ (edit event) + (when (preferences:get 'framework:overwrite-mode-keybindings) + (send edit set-overwrite-mode + (not (send edit get-overwrite-mode)))))] + + [down-into-embedded-editor + (λ (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let* ([bx (box 0)] + [after-snip (send text find-snip start 'after-or-none bx)]) + (cond + [(and (= (unbox bx) start) + after-snip + (is-a? after-snip editor-snip%)) + (let ([embedded-editor (send after-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position 0)) + (send embedded-editor set-caret-owner #f 'global))] + [else + (let ([before-snip (send text find-snip start 'before-or-none bx)]) + (when (and (= (+ (unbox bx) 1) start) + before-snip + (is-a? before-snip editor-snip%)) + (let ([embedded-editor (send before-snip get-editor)]) + (when (is-a? embedded-editor text%) + (send embedded-editor set-position + (send embedded-editor last-position))) + (send embedded-editor set-caret-owner #f 'global))))])))) + #t)] + + [forward-to-next-embedded-editor + (λ (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'after-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (send text get-snip-position snip))] + [else (loop (send snip next))])))) + #t)] + + [back-to-prev-embedded-editor + (λ (text event) + (let ([start-pos (send text get-start-position)] + [end-pos (send text get-end-position)]) + (when (= start-pos end-pos) + (let loop ([snip (send text find-snip start-pos 'before-or-none)]) + (cond + [(not snip) (void)] + [(is-a? snip editor-snip%) + (send text set-position (+ (send text get-snip-position snip) 1))] + [else (loop (send snip previous))])))) + #t)] + + [up-out-of-embedded-editor + (λ (text event) + (let ([start (send text get-start-position)] + [end (send text get-end-position)]) + (when (= start end) + (let ([editor-admin (send text get-admin)]) + (when (is-a? editor-admin editor-snip-editor-admin<%>) + (let* ([snip (send editor-admin get-snip)] + [snip-admin (send snip get-admin)]) + (when snip-admin + (let ([editor (send snip-admin get-editor)]) + (when (is-a? editor text%) + (let ([new-pos (send editor get-snip-position snip)]) + (send editor set-position new-pos new-pos)) + (send editor set-caret-owner #f 'display))))))))) + #t)] + + [make-read-only + (λ (text event) + (send text lock #t) + #t)] + + [newline + (λ (text event) + (send text insert "\n") + #t)] + + [shift-focus + (λ (adjust) + (λ (text event) + (when (is-a? text editor:basic<%>) + (let ([frame (send text get-top-level-window)] + [found-one? #f]) + (let/ec k + (let ([go + (λ () + (let loop ([obj frame]) + (cond + [(and found-one? + (is-a? obj editor-canvas%) + (is-a? (send obj get-editor) editor:keymap<%>)) + (send obj focus) + (k (void))] + [(and (is-a? obj window<%>) (send obj has-focus?)) + (set! found-one? #t)] + [(is-a? obj area-container<%>) + (for-each loop (adjust (send obj get-children)))])))]) + (go) + ;;; when we get here, we either didn't find the focus anywhere, + ;;; or the last editor-canvas had the focus. either way, + ;;; the next thing should get the focus + (set! found-one? #t) + (go)))))))] + + [TeX-compress + (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) + (define (meet s t) + (substring s 0 (string-prefix-length s t 0))) + (λ (text event) + (define pos (send text get-start-position)) + (when (= pos (send text get-end-position)) + (define slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1)))) + (when slash + (define entered (send text get-text slash pos)) + (define completions + (filter (λ (shortcut) (string-prefix? entered (first shortcut))) + tex-shortcut-table)) + (unless (empty? completions) + (define-values (replacement partial?) + (let ([complete-match + (findf (λ (shortcut) (equal? entered (first shortcut))) + completions)]) + (if complete-match + (values (second complete-match) #f) + (if (= 1 (length completions)) + (values (second (first completions)) #f) + (let ([tex-names (map first completions)]) + (values (foldl meet (first tex-names) (rest tex-names)) + #t)))))) + (send text begin-edit-sequence) + (send text delete (if partial? slash (- slash 1)) pos) + (send text insert replacement) + (send text end-edit-sequence))))))] + + [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] + [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"] + ;; don't have a capital ς, just comes out as \u03A2 (or junk) + + + [find-beginning-of-line + (λ (txt) + (define pos-to-start-with + (cond + [(= (send txt get-extend-start-position) + (send txt get-start-position)) + (send txt get-end-position)] + [else + (send txt get-start-position)])) + + (cond + [(is-a? txt text:basic<%>) + (send txt get-start-of-line pos-to-start-with)] + [(is-a? txt text%) + (send txt line-start-position (send txt position-line pos-to-start-with))] + [else #f]))] + [beginning-of-line + (λ (txt event) + (define pos (find-beginning-of-line txt)) + (when pos + (send txt set-position pos pos)))] + [select-to-beginning-of-line + (λ (txt event) + (define pos (find-beginning-of-line txt)) + (when pos + (send txt extend-position pos)))] + + + [normalize-unicode-ascii-art-box + (λ (txt evt) + (define start (send txt get-start-position)) + (when (= start (send txt get-end-position)) + (normalize-unicode-ascii-art-box txt start) + (send txt set-position start)))] + + [widen-unicode-ascii-art-box + (λ (txt evt) + (define start (send txt get-start-position)) + (when (= start (send txt get-end-position)) + (widen-unicode-ascii-art-box txt start)))] + + [center-in-unicode-ascii-art-box + (λ (txt evt) + (define start (send txt get-start-position)) + (when (= start (send txt get-end-position)) + (center-in-unicode-ascii-art-box txt start)))]) + + (λ (kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f]) + (let* ([map (λ (key func) + (send kmap map-function key func))] + [map-meta (λ (key func) + (keymap:send-map-function-meta kmap key func + (regexp-match? has-control-regexp key) + #:alt-as-meta-keymap alt-as-meta-keymap))] + [add (λ (name func) + (send kmap add-function name func))] + [add-m (λ (name func) + (send kmap add-function name func) + (when alt-as-meta-keymap + (send alt-as-meta-keymap add-function name func)))]) + + ; Map names to keyboard functions + + (for-each + (λ (c) + (unless (equal? c #\space) + (add (format "insert ~a" c) + (λ (txt evt) (send txt insert c))))) + (string->list (string-append greek-letters Greek-letters))) + + (add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box) + (add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box) + (add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box) + (add "shift-focus" (shift-focus values)) + (add "shift-focus-backwards" (shift-focus reverse)) + + (add "TeX compress" TeX-compress) + (add "newline" newline) + (add-m "down-into-embedded-editor" down-into-embedded-editor) + (add-m "up-out-of-embedded-editor" up-out-of-embedded-editor) + (add-m "forward-to-next-embedded-editor" forward-to-next-embedded-editor) + (add-m "back-to-prev-embedded-editor" back-to-prev-embedded-editor) + + (add-m "toggle-overwrite (when enabled in prefs)" toggle-overwrite) + + (add "exit" (λ (edit event) + (let ([frame (send edit get-frame)]) + (if (and frame + (is-a? frame frame:standard-menus<%>)) + (send frame file-menu:quit) + (bell))))) + + (add "ring-bell" ring-bell) + + + (add "toggle-anchor" toggle-anchor) + (add "center-view-on-line" center-view-on-line) + (add-m "collapse-space" collapse-space) + (add "remove-space" remove-space) + (add "collapse-newline" collapse-newline) + (add "open-line" open-line) + (add "transpose-chars" transpose-chars) + (add-m "transpose-words" transpose-words) + (add-m "capitalize-word" capitalize-word) + (add-m "upcase-word" upcase-word) + (add-m "downcase-word" downcase-word) + (add-m "kill-word" kill-word) + (add-m "backward-kill-word" backward-kill-word) + + (let loop ([n 9]) + (unless (negative? n) + (let ([s (number->string n)]) + (add-m (string-append "command-repeat-" s) + (make-make-repeater n)) + (loop (sub1 n))))) + + (add "keyboard-macro-run-saved" do-macro) + (add "keyboard-macro-start-record" start-macro) + (add "keyboard-macro-end-record" end-macro) + + (add-m "copy-clipboard" mouse-copy-clipboard) + (add-m "copy-clipboard/disable-anchor" mouse-copy-clipboard/disable-anchor) + (add-m "cut-clipboard" mouse-cut-clipboard) + (add-m "paste-clipboard" mouse-paste-clipboard) + (add-m "copy-click-region" copy-click-region) + (add-m "cut-click-region" cut-click-region) + (add-m "paste-click-region" paste-click-region) + (add-m "select-click-word" select-click-word) + (add-m "select-click-line" select-click-line) + + (add "delete-key" delete-key) + + (add "mouse-popup-menu" mouse-popup-menu) + + (add "make-read-only" make-read-only) + + (add "beginning-of-line" beginning-of-line) + (add "select-to-beginning-of-line" select-to-beginning-of-line) + + ; Map keys to functions + + (let ([setup-mappings + (λ (greek-chars shift?) + (let loop ([i 0]) + (when (< i (string-length greek-chars)) + (let ([greek-char (string-ref greek-chars i)]) + (unless (equal? greek-char #\space) + (let ([roman-char + (integer->char + (+ (char->integer #\a) i))]) + (map (format "a:g;~a~a" + (if shift? "s:" "") + roman-char) + (format "insert ~a" greek-char)) + (map (format "~~c:m:x;c:g;~a~a" + (if shift? "s:" "") + roman-char) + (format "insert ~a" greek-char)) + (map (format "c:x;c:g;~a~a" + (if shift? "s:" "") + roman-char) + (format "insert ~a" greek-char))))) + (loop (+ i 1)))))]) + (setup-mappings greek-letters #f) + (setup-mappings Greek-letters #t)) + + (map "c:x;r;a" "normalize-unicode-ascii-art-box") + (map "c:x;r;w" "widen-unicode-ascii-art-box") + (map "c:x;r;c" "center-in-unicode-ascii-art-box") + + (map "~m:c:\\" "TeX compress") + (map "~c:m:\\" "TeX compress") + (map "c:x;t" "TeX compress") + + (map "c:j" "newline") + + (map-meta "c:down" "down-into-embedded-editor") + (map "a:c:down" "down-into-embedded-editor") + (map-meta "c:up" "up-out-of-embedded-editor") + (map "a:c:up" "up-out-of-embedded-editor") + (map-meta "c:right" "forward-to-next-embedded-editor") + (map "a:c:right" "forward-to-next-embedded-editor") + (map-meta "c:left" "back-to-prev-embedded-editor") + (map "a:c:left" "back-to-prev-embedded-editor") + + (map "c:c;c:g" "ring-bell") + + (map "c:p" "previous-line") + (map "up" "previous-line") + (map "s:c:p" "select-up") + (map "s:up" "select-up") + + (map "c:n" "next-line") + (map "down" "next-line") + (map "s:c:n" "select-down") + (map "s:down" "select-down") + + (map "c:e" "end-of-line") + (map "d:right" "end-of-line") + (map "end" "end-of-line") + (map "s:end" "select-to-end-of-line") + (map "s:c:e" "select-to-end-of-line") + (map "s:d:right" "select-to-end-of-line") + + (map "c:a" "beginning-of-line") + (map "d:left" "beginning-of-line") + (map "home" "beginning-of-line") + (map "s:home" "select-to-beginning-of-line") + (map "s:c:a" "select-to-beginning-of-line") + (map "s:d:left" "select-to-beginning-of-line") + + (map "c:f" "forward-character") + (map "right" "forward-character") + (map "s:c:f" "forward-select") + (map "s:right" "forward-select") + + (map "c:b" "backward-character") + (map "left" "backward-character") + (map "s:c:b" "backward-select") + (map "s:left" "backward-select") + + (map-meta "f" "forward-word") + (map "c:right" "forward-word") + (map-meta "s:f" "forward-select-word") + (map "c:s:right" "forward-select-word") + + (map-meta "b" "backward-word") + + (map "c:left" "backward-word") + (map-meta "s:b" "backward-select-word") + (map "c:s:left" "backward-select-word") + + (map-meta "<" "beginning-of-file") + (map "d:up" "beginning-of-file") + (map "c:home" "beginning-of-file") + (map "s:c:home" "select-to-beginning-of-file") + (map "s:d:up" "select-to-beginning-of-file") + + (map-meta ">" "end-of-file") + (map "d:down" "end-of-file") + (map "c:end" "end-of-file") + (map "s:c:end" "select-to-end-of-file") + (map "s:d:down" "select-to-end-of-file") + + (map "c:v" "next-page") + (map "pagedown" "next-page") + (map "c:down" "next-page") + (map "s:c:v" "select-page-down") + (map "s:pagedown" "select-page-down") + (map "s:c:down" "select-page-down") + + (map-meta "v" "previous-page") + (map "pageup" "previous-page") + (map "c:up" "previous-page") + (map-meta "s:v" "select-page-up") + (map "s:pageup" "select-page-up") + (map "s:c:up" "select-page-up") + + (map "c:h" "delete-previous-character") + (map "c:d" "delete-next-character") + (map "del" "delete-key") + + (map-meta "d" "kill-word") + (map-meta "del" "kill-word") + (map-meta "backspace" "backward-kill-word") + (map-meta "c" "capitalize-word") + (map-meta "u" "upcase-word") + (map-meta "l" "downcase-word") + + (map "c:l" "center-view-on-line") + + (map "c:k" "delete-to-end-of-line") + (map "c:y" "paste-clipboard") + (map-meta "y" "paste-next") + (map "a:v" "paste-clipboard") + (map "d:v" "paste-clipboard") + (map "c:_" "undo") + (map "c:/" "undo") + (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange + (map "c:+" "redo") + (map "a:z" "undo") + (map "d:z" "undo") + (map "c:x;u" "undo") + (map "c:w" "cut-clipboard") + (map "a:x" "cut-clipboard") + (map "d:x" "cut-clipboard") + (map-meta "w" "copy-clipboard/disable-anchor") + (map "a:c" "copy-clipboard") + (map "d:c" "copy-clipboard") + + (map "s:delete" "cut-clipboard") + (map "c:insert" "copy-clipboard") + (map "s:insert" "paste-clipboard") + + (map-meta "space" "collapse-space") + (when (eq? (system-type) 'macosx) + (map "a:space" "collapse-space")) + ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards. + (map "c:x;c:o" "collapse-newline") + (map "c:o" "open-line") + (map "c:t" "transpose-chars") + (map-meta "t" "transpose-words") + + (map "c:space" "toggle-anchor") + + (map "insert" "toggle-overwrite (when enabled in prefs)") + (map-meta "o" "toggle-overwrite (when enabled in prefs)") + + (map "c:u" "command-repeat-0") + (let loop ([n 9]) + (unless (negative? n) + (let ([s (number->string n)]) + (map-meta s (string-append "command-repeat-" s)) + (loop (sub1 n))))) + + (map "c:x;e" "keyboard-macro-run-saved") + (map "c:x;(" "keyboard-macro-start-record") + (map "c:x;)" "keyboard-macro-end-record") + + (map "leftbuttontriple" "select-click-line") + (map "leftbuttondouble" "select-click-word") + + ;; the "roller ball" mice map clicking the ball to button 2. + (unless (eq? (system-type) 'windows) + (map "middlebutton" "paste-click-region")) + + (map ":rightbuttonseq" "mouse-popup-menu") + + (map "c:c;c:r" "make-read-only") + + (map "c:x;o" "shift-focus") + (map "c:x;p" "shift-focus-backwards") + (map "c:f6" "shift-focus") + (map "a:tab" "shift-focus") + (map "a:s:tab" "shift-focus-backwards"))))) + +(define (keymap:region-click text event f) + (region-click/internal text event + (λ (click-pos eol start end) (f click-pos eol)))) + +(define (region-click/internal text event f) + (when (and (is-a? event mouse-event%) + (send event button-down?) + (is-a? text text%)) + (define x-box (box (send event get-x))) + (define y-box (box (send event get-y))) + (define eol-box (box #f)) + (send text global-to-local x-box y-box) + (define click-pos (send text find-position + (unbox x-box) + (unbox y-box) + eol-box)) + (define start-pos (send text get-start-position)) + (define end-pos (send text get-end-position)) + (define eol (unbox eol-box)) + (if (< start-pos click-pos) + (f click-pos eol start-pos click-pos) + (f click-pos eol click-pos end-pos)))) + + + +(define (widen-unicode-ascii-art-box t orig-pos) + (define start-pos (scan-for-start-pos t orig-pos)) + (when start-pos + (send t begin-edit-sequence) + (define-values (start-x start-y) (pos->xy t orig-pos)) + (define min-y #f) + (define max-y #f) + (trace-unicode-ascii-art-box + t start-pos #f + (λ (pos x y i-up? i-dn? i-lt? i-rt?) + (when (= x start-x) + (unless min-y + (set! min-y y) + (set! max-y y)) + (set! min-y (min y min-y)) + (set! max-y (max y max-y))))) + (define to-adjust 0) + (for ([y (in-range max-y (- min-y 1) -1)]) + (define-values (pos char) (xy->pos t start-x y)) + (when (< pos start-pos) + (set! to-adjust (+ to-adjust 1))) + (send t insert + (cond + [(member char lt-chars) #\═] + [else #\space]) + pos pos)) + (send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1)) + (send t end-edit-sequence))) + +(define (normalize-unicode-ascii-art-box t pos) + (define start-pos (scan-for-start-pos t pos)) + (when start-pos + (send t begin-edit-sequence) + (trace-unicode-ascii-art-box + t start-pos #f + (λ (pos x y i-up? i-dn? i-lt? i-rt?) + (cond + [(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")] + [(and i-dn? i-lt? i-rt?) (set-c t pos "╦")] + [(and i-up? i-lt? i-rt?) (set-c t pos "╩")] + [(and i-up? i-dn? i-rt?) (set-c t pos "╠")] + [(and i-up? i-dn? i-lt?) (set-c t pos "╣")] + [(and i-up? i-lt?) (set-c t pos "╝")] + [(and i-up? i-rt?) (set-c t pos "╚")] + [(and i-dn? i-lt?) (set-c t pos "╗")] + [(and i-dn? i-rt?) (set-c t pos "╔")] + [(or i-up? i-dn?) (set-c t pos "║")] + [else (set-c t pos "═")]))) + (send t end-edit-sequence))) + +(define (center-in-unicode-ascii-art-box txt insertion-pos) + (define (find-something start-pos inc char-p?) + (define-values (x y) (pos->xy txt start-pos)) + (let loop ([pos start-pos]) + (cond + [(char-p? (send txt get-character pos)) + pos] + [else + (define new-pos (inc pos)) + (cond + [(<= 0 new-pos (send txt last-position)) + (define-values (x2 y2) (pos->xy txt new-pos)) + (cond + [(= y2 y) + (loop new-pos)] + [else #f])] + [else #f])]))) + + (define (adjust-space before-space after-space pos) + (cond + [(< before-space after-space) + (send txt insert (make-string (- after-space before-space) #\space) pos pos)] + [(> before-space after-space) + (send txt delete pos (+ pos (- before-space after-space)))])) + + (define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║)))) + (define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║)))) + (when (and left-bar right-bar (< left-bar right-bar)) + (define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x))))) + (define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x))))) + (when (and left-space-edge right-space-edge) + (define before-left-space-count (- left-space-edge left-bar 1)) + (define before-right-space-count (- right-bar right-space-edge 1)) + (define tot-space (+ before-left-space-count before-right-space-count)) + (define after-left-space-count (floor (/ tot-space 2))) + (define after-right-space-count (ceiling (/ tot-space 2))) + (send txt begin-edit-sequence) + (adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1)) + (adjust-space before-left-space-count after-left-space-count (+ left-bar 1)) + (send txt end-edit-sequence)))) + +(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f) + (define visited (make-hash)) + (let loop ([pos start-pos]) + (unless (hash-ref visited pos #f) + (hash-set! visited pos #t) + (define-values (x y) (pos->xy t pos)) + (define c (send t get-character pos)) + (define-values (up upc) (xy->pos t x (- y 1))) + (define-values (dn dnc) (xy->pos t x (+ y 1))) + (define-values (lt ltc) (xy->pos t (- x 1) y)) + (define-values (rt rtc) (xy->pos t (+ x 1) y)) + (define (interesting-dir? dir-c dir-chars) + (or (and (not only-double-barred-chars?) + (member dir-c adjustable-chars) + (member c dir-chars)) + (and (member dir-c double-barred-chars) + (member c double-barred-chars)))) + (define i-up? (interesting-dir? upc up-chars)) + (define i-dn? (interesting-dir? dnc dn-chars)) + (define i-lt? (interesting-dir? ltc lt-chars)) + (define i-rt? (interesting-dir? rtc rt-chars)) + (f pos x y i-up? i-dn? i-lt? i-rt?) + (when i-up? (loop up)) + (when i-dn? (loop dn)) + (when i-lt? (loop lt)) + (when i-rt? (loop rt))))) + +(define (scan-for-start-pos t pos) + (define-values (x y) (pos->xy t pos)) + (findf + (λ (p) (adj? t p)) + (for*/list ([xadj '(0 -1)] + [yadj '(0 -1 1)]) + (define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj))) + d))) + +(define (adj? t pos) + (and pos + (member (send t get-character pos) + adjustable-chars))) + +(define (set-c t pos s) + (unless (equal? (string-ref s 0) (send t get-character pos)) + (send t delete pos (+ pos 1)) + (send t insert s pos pos))) + +(define (pos->xy text pos) + (define para (send text position-paragraph pos)) + (define start (send text paragraph-start-position para)) + (values (- pos start) para)) + +(define (xy->pos text x y) + (cond + [(and (<= 0 x) (<= 0 y (send text last-paragraph))) + (define para-start (send text paragraph-start-position y)) + (define para-end (send text paragraph-end-position y)) + (define pos (+ para-start x)) + (define res-pos + (and (< pos para-end) + ;; the newline at the end of the + ;; line is not on the line, so use this guard + pos)) + (if res-pos + (values res-pos (send text get-character res-pos)) + (values #f #f))] + [else (values #f #f)])) + +(module+ test + (require rackunit + racket/gui/base) + (define sa string-append) + + (define (first-value-xy->pos a b c) + (define-values (d e) (xy->pos a b c)) + d) + + (let ([t (new text%)]) + (send t insert (sa "abc\n" + "d\n" + "ghi\n")) + (check-equal? (first-value-xy->pos t 0 0) 0) + (check-equal? (first-value-xy->pos t 1 0) 1) + (check-equal? (first-value-xy->pos t 0 1) 4) + (check-equal? (first-value-xy->pos t 3 0) #f) + (check-equal? (first-value-xy->pos t 0 3) #f) + (check-equal? (first-value-xy->pos t 1 1) #f) + (check-equal? (first-value-xy->pos t 2 1) #f) + (check-equal? (first-value-xy->pos t 0 2) 6) + (check-equal? (first-value-xy->pos t 1 2) 7) + (check-equal? (first-value-xy->pos t 2 -1) #f) + (check-equal? (first-value-xy->pos t -1 0) #f) + (check-equal? (first-value-xy->pos t 2 2) 8) + (check-equal? (first-value-xy->pos t 2 3) #f)) + + (let ([t (new text%)]) + (send t insert (sa "abc\n" + "d\n" + "ghi")) + (check-equal? (first-value-xy->pos t 2 2) 8) + (check-equal? (first-value-xy->pos t 2 3) #f)) + + (let ([t (new text%)]) + (send t insert (string-append "+-+\n" + "| |\n" + "+-+\n")) + (normalize-unicode-ascii-art-box t 0) + (check-equal? (send t get-text) + (string-append + "╔═╗\n" + "║ ║\n" + "╚═╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append "+=+\n" + "| |\n" + "+=+\n")) + (normalize-unicode-ascii-art-box t 0) + (check-equal? (send t get-text) + (string-append + "╔═╗\n" + "║ ║\n" + "╚═╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append "+-+-+\n" + "| | |\n" + "+-+-+\n" + "| | |\n" + "+-+-+\n")) + (normalize-unicode-ascii-art-box t 0) + (check-equal? (send t get-text) + (string-append + "╔═╦═╗\n" + "║ ║ ║\n" + "╠═╬═╣\n" + "║ ║ ║\n" + "╚═╩═╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append + "╔═══╗\n" + "║ - ║\n" + "╚═══╝\n")) + + (normalize-unicode-ascii-art-box t 0) + (check-equal? (send t get-text) + (string-append + "╔═══╗\n" + "║ - ║\n" + "╚═══╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append + "╔═╦═╗\n" + "║ ║ ║\n" + "╠═╬═╣\n" + "║ ║ ║\n" + "╚═╩═╝\n")) + (send t set-position 1 1) + (widen-unicode-ascii-art-box t 1) + (check-equal? (send t get-start-position) 2) + (check-equal? (send t get-text) + (string-append + "╔══╦═╗\n" + "║ ║ ║\n" + "╠══╬═╣\n" + "║ ║ ║\n" + "╚══╩═╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append + "╔═╦═╗\n" + "║ ║ ║\n" + "╠═╬═╣\n" + "║ ║ ║\n" + "╚═╩═╝\n")) + (send t set-position 8 8) + (widen-unicode-ascii-art-box t 8) + (check-equal? (send t get-start-position) 10) + (check-equal? (send t get-text) + (string-append + "╔══╦═╗\n" + "║ ║ ║\n" + "╠══╬═╣\n" + "║ ║ ║\n" + "╚══╩═╝\n"))) + + (let ([t (new text%)]) + (send t insert (string-append + "╔═╦═╗\n" + "║ ║ ║\n" + "╠═╬═╣\n" + "║ ║ ║\n")) + (send t set-position 8 8) + (widen-unicode-ascii-art-box t 8) + (check-equal? (send t get-text) + (string-append + "╔══╦═╗\n" + "║ ║ ║\n" + "╠══╬═╣\n" + "║ ║ ║\n"))) + + (let ([t (new text%)]) + (send t insert "║ x ║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║ x ║\n")) + + (let ([t (new text%)]) + (send t insert "║x ║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║ x ║\n")) + + (let ([t (new text%)]) + (send t insert "║ x║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║ x ║\n")) + + (let ([t (new text%)]) + (send t insert "║abcde║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║abcde║\n")) + + (let ([t (new text%)]) + (send t insert "║║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║║\n")) + + (let ([t (new text%)]) + (send t insert "║abcde \n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + "║abcde \n")) + + (let ([t (new text%)]) + (send t insert " abcde║\n") + (center-in-unicode-ascii-art-box t 1) + (check-equal? (send t get-text) + " abcde║\n"))) diff --git a/gui-lib/framework/private/keymap.rkt b/gui-lib/framework/private/keymap.rkt index 9fb2b2b4..d74c8869 100644 --- a/gui-lib/framework/private/keymap.rkt +++ b/gui-lib/framework/private/keymap.rkt @@ -4,14 +4,12 @@ racket/class racket/match racket/list - racket/set racket/unit mred/mred-sig "../preferences.rkt" - unstable/2d/dir-chars - mrlib/tex-table - (only-in srfi/13 string-prefix? string-prefix-length) - "sig.rkt") + "sig.rkt" + "keymap-global.rkt") + (provide keymap@) (define-unit keymap@ @@ -334,1025 +332,62 @@ ;;;;;;; end canonicalize-keybinding-string ;;;;;;;; ;;;;;;; ;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (make-meta-prefix-list key [mask-control? #f]) - ;; Note: key canonicalization will remove "~g" when redundant - (list (if mask-control? - (string-append "~g:m:" key) - (string-append "~c:~g:m:" key)) - (string-append "ESC;" key))) - - (define (send-map-function-meta keymap key func [mask-control? #f] - #:alt-as-meta-keymap [alt-as-meta-keymap #f]) - (for ([key (in-list (make-meta-prefix-list key mask-control?))]) - (send keymap map-function key func)) - (when alt-as-meta-keymap - (unless (send alt-as-meta-keymap is-function-added? func) - (error 'send-map-function-meta - "expected to find ~s mapped in alt-as-meta-keymap" - func)) - (send alt-as-meta-keymap map-function (string-append "?:a:" key) func))) - - (define has-control-regexp #rx"(?:^|:)c:") - - (define add-to-right-button-menu (make-parameter void)) - (define add-to-right-button-menu/before (make-parameter void)) - - (define setup-global - ; Define some useful keyboard functions - (let* ([ring-bell - (λ (edit event) - (bell))] - - [mouse-popup-menu - (λ (edit event) - (when (send event button-up?) - (let ([a (send edit get-admin)]) - (when a - (let ([m (make-object popup-menu%)]) - - ((add-to-right-button-menu/before) m edit event) - - (append-editor-operation-menu-items - m #:popup-position - (list edit - (send edit find-position (send event get-x) (send event get-y)))) - (for-each - (λ (i) - (when (is-a? i selectable-menu-item<%>) - (send i set-shortcut #f))) - (send m get-items)) - - ((add-to-right-button-menu) m edit event) - - (let-values ([(x y) (send edit - dc-location-to-editor-location - (send event get-x) - (send event get-y))]) - (send a popup-menu m (+ x 1) (+ y 1))))))))] - - [toggle-anchor - (λ (edit event) - (send edit set-anchor - (not (send edit get-anchor))))] - [center-view-on-line - (λ (edit event) - (let ([new-mid-line (send edit position-line - (send edit get-start-position))] - [bt (box 0)] - [bb (box 0)]) - (send edit get-visible-line-range bt bb #f) - (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] - [last-pos (send edit position-line (send edit last-position))] - [top-pos (send edit line-start-position - (max (min (- new-mid-line half) last-pos) 0))] - [bottom-pos (send edit line-start-position - (max 0 - (min (+ new-mid-line half) - last-pos)))]) - (send edit scroll-to-position - top-pos - #f - bottom-pos))) - #t)] - - - [collapse-variable-space - ;; As per emacs: collapse tabs & spaces around the point, - ;; perhaps leaving a single space. - ;; drscheme bonus: if at end-of-line, collapse into the next line. - (λ (leave-one? edit event) - (letrec ([last-pos (send edit last-position)] - [sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)] - [collapsible? (λ (c) (and (char-whitespace? c) - (not (char=? #\newline c))))] - [find-noncollapsible - ; Return index of next non-collapsible char, - ; starting at pos in direction dir. - ; NB returns -1 or last-pos, if examining - ; initial/final whitespace - ; (or, when initial pos is outside of [0,last-pos).) - (λ (pos dir) - (let loop ([pos pos]) - (cond [(< pos 0) -1] - [(>= pos last-pos) last-pos] - [(collapsible? (send edit get-character pos)) - (loop (+ pos dir))] - [else pos])))]) - (when (= sel-start sel-end) ; Only when no selection: - (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))] - [end-heeding-eol (find-noncollapsible sel-start +1)] - ; This is the end of the range, were we to always heed newlines. - - ; Special case: if we're sitting at EOL, - ; and we're not affecting much else, - ; then delete that EOL and collapse spaces - ; at the start of next line, too: - [end (if (and (<= (- end-heeding-eol start) - (if leave-one? 1 0)) - (char=? #\newline (send edit get-character end-heeding-eol)) - ; If you wish to avoid deleting an newline at EOF, do so here. - ) - (find-noncollapsible (add1 end-heeding-eol) +1) - end-heeding-eol)] - [making-no-difference? - ; Don't introduce edits into undo-chain, if no effect. - (if leave-one? - (and (= (- end start) 1) - (char=? #\space (send edit get-character start))) - (= (- end start) 0))]) - (unless making-no-difference? - (send edit begin-edit-sequence) - (send edit set-position end) ; Even after delete, caret will be at "end". - (send edit delete start end) - (when leave-one? (send edit insert #\space start)) - (send edit end-edit-sequence))))))] - - [collapse-space - (λ (edit event) - (collapse-variable-space #t edit event))] - - [remove-space - (λ (edit event) - (collapse-variable-space #f edit event))] - - [collapse-newline - (λ (edit event) - (define (find-nonwhite pos d offset) - (define done (if (= offset -1) 0 (send edit last-position))) - (let/ec escape - (let loop ([pos pos]) - (cond - [(= pos done) (escape pos)] - [else - (define c (send edit get-character (+ pos offset))) - (cond - [(char=? #\newline c) - (loop (+ pos d)) - (escape pos)] - [(char-whitespace? c) - (loop (+ pos d))] - [else pos])])))) - (define sel-start (send edit get-start-position)) - (define sel-end (send edit get-end-position)) - (when (= sel-start sel-end) - (define pos-para (send edit position-paragraph sel-start #f)) - (define pos-para-start (send edit paragraph-start-position pos-para)) - (define pos-para-end (send edit paragraph-end-position pos-para)) - - (define whitepara? - (let loop ([pos pos-para-start]) - (if (>= pos pos-para-end) - #t - (and (char-whitespace? (send edit get-character pos)) - (loop (add1 pos)))))) - - (define start (find-nonwhite pos-para-start -1 -1)) - (define end (find-nonwhite pos-para-end 1 0)) - - (define start-para (send edit position-paragraph start #f)) - (define start-para-start (send edit paragraph-start-position start-para)) - (define end-para (send edit position-paragraph end #f)) - (define end-para-start (send edit paragraph-start-position (add1 end-para))) - (cond - [(and whitepara? - (= start-para pos-para) - (= end-para pos-para)) - ; Special case: just delete this para - (send edit delete pos-para-start (add1 pos-para-end))] - [(and whitepara? (< start-para pos-para)) - ; Can delete before & after - (send* edit - (begin-edit-sequence) - (delete (add1 pos-para-end) end-para-start) - (delete start-para-start pos-para-start) - (end-edit-sequence))] - [else - ; Only delete after - (send edit delete (add1 pos-para-end) end-para-start)])))] - - [open-line - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (send* edit - (insert #\newline) - (set-position sel-start)))))] - - [transpose-chars - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (and (= sel-start sel-end) - (not (= sel-start 0))) - - (let ([sel-start - (if (= sel-start - (send edit line-end-position - (send edit position-line sel-start))) - (sub1 sel-start) - sel-start)]) - (let ([s (send edit get-text - sel-start (add1 sel-start))]) - (send* edit - (begin-edit-sequence) - (delete sel-start (add1 sel-start)) - (insert s (- sel-start 1)) - (set-position (add1 sel-start)) - (end-edit-sequence)))))))] - - [transpose-words - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (let ([word-1-start (box sel-start)]) - (send edit find-wordbreak word-1-start #f 'caret) - (let ([word-1-end (box (unbox word-1-start))]) - (send edit find-wordbreak #f word-1-end 'caret) - (let ([word-2-end (box (unbox word-1-end))]) - (send edit find-wordbreak #f word-2-end 'caret) - (let ([word-2-start (box (unbox word-2-end))]) - (send edit find-wordbreak word-2-start #f 'caret) - (let ([text-1 (send edit get-text - (unbox word-1-start) - (unbox word-1-end))] - [text-2 (send edit get-text - (unbox word-2-start) - (unbox word-2-end))]) - (send* edit - (begin-edit-sequence) - (insert text-1 - (unbox word-2-start) - (unbox word-2-end)) - (insert text-2 - (unbox word-1-start) - (unbox word-1-end)) - (set-position (unbox word-2-end)) - (end-edit-sequence))))))))))] - - [capitalize-it - (λ (edit char-case1 char-case2) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)] - [real-end (send edit last-position)]) - (when (= sel-start sel-end) - (let ([word-end (let ([b (box sel-start)]) - (send edit find-wordbreak #f b 'caret) - (min real-end (unbox b)))]) - (send edit begin-edit-sequence) - (let loop ([pos sel-start] - [char-case char-case1]) - (when (< pos word-end) - (let ([c (send edit get-character pos)]) - (cond - [(char-alphabetic? c) - (send edit insert - (list->string - (list (char-case c))) - pos (add1 pos)) - (loop (add1 pos) char-case2)] - [else - (loop (add1 pos) char-case)])))) - (send* edit - (end-edit-sequence) - (set-position word-end))))))] - - [capitalize-word - (λ (edit event) - (capitalize-it edit char-upcase char-downcase))] - [upcase-word - (λ (edit event) - (capitalize-it edit char-upcase char-upcase))] - [downcase-word - (λ (edit event) - (capitalize-it edit char-downcase char-downcase))] - - [kill-word - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([end-box (box sel-end)]) - (send edit find-wordbreak #f end-box 'caret) - (send edit kill 0 sel-start (unbox end-box)))))] - - [backward-kill-word - (λ (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([start-box (box sel-start)]) - (send edit find-wordbreak start-box #f 'caret) - (send edit kill 0 (unbox start-box) sel-end))))] - [copy-click-region - (λ (edit event) - (region-click/internal edit event - (λ (click eol start end) - (send edit flash-on start end) - (send edit copy #f 0 start end))))] - [cut-click-region - (λ (edit event) - (region-click/internal edit event - (λ (click eol start end) - (send edit cut #f 0 start end))))] - [paste-click-region - (λ (edit event) - (region-click/internal edit event - (λ (click eol start end) - (send edit set-position click) - (send edit paste-x-selection 0 click))))] - - [mouse-copy-clipboard - (λ (edit event) - (send edit copy #f (send event get-time-stamp)))] - - [mouse-copy-clipboard/disable-anchor - (λ (edit event) - (send edit set-anchor #f) - (send edit copy #f (send event get-time-stamp)))] - - [mouse-paste-clipboard - (λ (edit event) - (send edit paste (send event get-time-stamp)))] - - [mouse-cut-clipboard - (λ (edit event) - (send edit cut #f (send event get-time-stamp)))] - - [select-click-word - (λ (edit event) - (region-click edit event - (λ (click eol) - (let ([start-box (box click)] - [end-box (box click)]) - (send edit find-wordbreak - start-box - end-box - 'selection) - (send edit set-position - (unbox start-box) - (unbox end-box))))))] - [select-click-line - (λ (edit event) - (region-click edit event - (λ (click eol) - (let* ([line (send edit position-line - click eol)] - [start (send edit line-start-position - line #f)] - [end (send edit line-end-position - line #f)]) - (send edit set-position start end)))))] - - [goto-line - (λ (edit event) - (let ([num-str - (call/text-keymap-initializer - (λ () - (get-text-from-user - (string-constant goto-line) - (string-constant goto-line))))]) - (when (string? num-str) - (let* ([possible-num (string->number num-str)] - [line-num (and possible-num (inexact->exact possible-num))]) - (cond - [(and (number? line-num) - (integer? line-num) - (<= 1 line-num (+ (send edit last-paragraph) 1))) - (let ([pos (send edit paragraph-start-position - (sub1 line-num))]) - (send edit set-position pos))] - [else - (message-box - (string-constant goto-line) - (format - (string-constant goto-line-invalid-number) - num-str - (+ (send edit last-line) 1)))])))) - - #t)] - [repeater - (λ (n edit) - (let* ([km (send edit get-keymap)] - [done - (λ () - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))]) - (send km set-grab-key-function - (λ (name local-km edit event) - (if name - (begin - (done) - (dynamic-wind - (λ () - (send edit begin-edit-sequence)) - (λ () - (let loop ([n n]) - (unless (zero? n) - (send local-km call-function name edit event) - (loop (sub1 n))))) - (λ () - (send edit end-edit-sequence)))) - (let ([k (send event get-key-code)]) - (if (and (char? k) (char<=? #\0 k #\9)) - (set! n (+ (* n 10) (- (char->integer k) - (char->integer #\0)))) - (begin - (done) - (dynamic-wind - (λ () - (send edit begin-edit-sequence)) - (λ () - (let loop ([n n]) - (unless (zero? n) - (send edit on-char event) - (loop (sub1 n))))) - (λ () - (send edit end-edit-sequence))))))) - #t)) - (send km set-break-sequence-callback done) - #t))] - [make-make-repeater - (λ (n) - (λ (edit event) - (repeater n edit)))] - [current-macro '()] - [building-macro #f] [build-macro-km #f] [build-protect? #f] - [show/hide-keyboard-macro-icon - (λ (edit on?) - (when (is-a? edit editor:basic<%>) - (let ([frame (send edit get-top-level-window)]) - (when (is-a? frame frame:text-info<%>) - (send frame set-macro-recording on?) - (send frame update-shown)))))] - - [do-macro - (λ (edit event) - ; If c:x;e during record, copy the old macro - (when building-macro - (set! building-macro (append (reverse current-macro) - (cdr building-macro)))) - (let ([bm building-macro] - [km (send edit get-keymap)]) - (dynamic-wind - (λ () - (set! building-macro #f) - (send edit begin-edit-sequence)) - (λ () - (let/ec escape - (for-each - (λ (f) - (let ([name (car f)] - [event (cdr f)]) - (if name - (unless (send km call-function name edit event #t) - (escape #t)) - (send edit on-char event)))) - current-macro))) - (λ () - (send edit end-edit-sequence) - (set! building-macro bm)))) - #t)] - [start-macro - (λ (edit event) - (if building-macro - (send build-macro-km break-sequence) - (letrec ([km (send edit get-keymap)] - [done - (λ () - (if build-protect? - (send km set-break-sequence-callback done) - (begin - (set! building-macro #f) - (show/hide-keyboard-macro-icon edit #f) - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))))]) - (set! building-macro '()) - (show/hide-keyboard-macro-icon edit #t) - (set! build-macro-km km) - (send km set-grab-key-function - (λ (name local-km edit event) - (dynamic-wind - (λ () - (set! build-protect? #t)) - (λ () - (if name - (send local-km call-function name edit event) - (send edit on-default-char event))) - (λ () - (set! build-protect? #f))) - (when building-macro - (set! building-macro - (cons (cons name event) - building-macro))) - #t)) - (send km set-break-sequence-callback done))) - #t)] - [end-macro - (λ (edit event) - (when building-macro - (set! current-macro (reverse building-macro)) - (set! build-protect? #f) - (send build-macro-km break-sequence)) - #t)] - [delete-key - (λ (edit event) - (let ([kmap (send edit get-keymap)]) - (send kmap call-function - (if (preferences:get 'framework:delete-forward?) - "delete-next-character" - "delete-previous-character") - edit event #t)))] - - [toggle-overwrite - (λ (edit event) - (when (preferences:get 'framework:overwrite-mode-keybindings) - (send edit set-overwrite-mode - (not (send edit get-overwrite-mode)))))] - - [down-into-embedded-editor - (λ (text event) - (let ([start (send text get-start-position)] - [end (send text get-end-position)]) - (when (= start end) - (let* ([bx (box 0)] - [after-snip (send text find-snip start 'after-or-none bx)]) - (cond - [(and (= (unbox bx) start) - after-snip - (is-a? after-snip editor-snip%)) - (let ([embedded-editor (send after-snip get-editor)]) - (when (is-a? embedded-editor text%) - (send embedded-editor set-position 0)) - (send embedded-editor set-caret-owner #f 'global))] - [else - (let ([before-snip (send text find-snip start 'before-or-none bx)]) - (when (and (= (+ (unbox bx) 1) start) - before-snip - (is-a? before-snip editor-snip%)) - (let ([embedded-editor (send before-snip get-editor)]) - (when (is-a? embedded-editor text%) - (send embedded-editor set-position - (send embedded-editor last-position))) - (send embedded-editor set-caret-owner #f 'global))))])))) - #t)] - - [forward-to-next-embedded-editor - (λ (text event) - (let ([start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) - (when (= start-pos end-pos) - (let loop ([snip (send text find-snip start-pos 'after-or-none)]) - (cond - [(not snip) (void)] - [(is-a? snip editor-snip%) - (send text set-position (send text get-snip-position snip))] - [else (loop (send snip next))])))) - #t)] - - [back-to-prev-embedded-editor - (λ (text event) - (let ([start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) - (when (= start-pos end-pos) - (let loop ([snip (send text find-snip start-pos 'before-or-none)]) - (cond - [(not snip) (void)] - [(is-a? snip editor-snip%) - (send text set-position (+ (send text get-snip-position snip) 1))] - [else (loop (send snip previous))])))) - #t)] - - [up-out-of-embedded-editor - (λ (text event) - (let ([start (send text get-start-position)] - [end (send text get-end-position)]) - (when (= start end) - (let ([editor-admin (send text get-admin)]) - (when (is-a? editor-admin editor-snip-editor-admin<%>) - (let* ([snip (send editor-admin get-snip)] - [snip-admin (send snip get-admin)]) - (when snip-admin - (let ([editor (send snip-admin get-editor)]) - (when (is-a? editor text%) - (let ([new-pos (send editor get-snip-position snip)]) - (send editor set-position new-pos new-pos)) - (send editor set-caret-owner #f 'display))))))))) - #t)] - - [make-read-only - (λ (text event) - (send text lock #t) - #t)] - - [newline - (λ (text event) - (send text insert "\n") - #t)] - - [shift-focus - (λ (adjust) - (λ (text event) - (when (is-a? text editor:basic<%>) - (let ([frame (send text get-top-level-window)] - [found-one? #f]) - (let/ec k - (let ([go - (λ () - (let loop ([obj frame]) - (cond - [(and found-one? - (is-a? obj editor-canvas%) - (is-a? (send obj get-editor) editor:keymap<%>)) - (send obj focus) - (k (void))] - [(and (is-a? obj window<%>) (send obj has-focus?)) - (set! found-one? #t)] - [(is-a? obj area-container<%>) - (for-each loop (adjust (send obj get-children)))])))]) - (go) - ;;; when we get here, we either didn't find the focus anywhere, - ;;; or the last editor-canvas had the focus. either way, - ;;; the next thing should get the focus - (set! found-one? #t) - (go)))))))] - - [TeX-compress - (let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))]) - (define (meet s t) - (substring s 0 (string-prefix-length s t 0))) - (λ (text event) - (define pos (send text get-start-position)) - (when (= pos (send text get-end-position)) - (define slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1)))) - (when slash - (define entered (send text get-text slash pos)) - (define completions - (filter (λ (shortcut) (string-prefix? entered (first shortcut))) - tex-shortcut-table)) - (unless (empty? completions) - (define-values (replacement partial?) - (let ([complete-match - (findf (λ (shortcut) (equal? entered (first shortcut))) - completions)]) - (if complete-match - (values (second complete-match) #f) - (if (= 1 (length completions)) - (values (second (first completions)) #f) - (let ([tex-names (map first completions)]) - (values (foldl meet (first tex-names) (rest tex-names)) - #t)))))) - (send text begin-edit-sequence) - (send text delete (if partial? slash (- slash 1)) pos) - (send text insert replacement) - (send text end-edit-sequence))))))] - - [greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"] - [Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"] - ;; don't have a capital ς, just comes out as \u03A2 (or junk) - - - [find-beginning-of-line - (λ (txt) - (define pos-to-start-with - (cond - [(= (send txt get-extend-start-position) - (send txt get-start-position)) - (send txt get-end-position)] - [else - (send txt get-start-position)])) - - (cond - [(is-a? txt text:basic<%>) - (send txt get-start-of-line pos-to-start-with)] - [(is-a? txt text%) - (send txt line-start-position (send txt position-line pos-to-start-with))] - [else #f]))] - [beginning-of-line - (λ (txt event) - (define pos (find-beginning-of-line txt)) - (when pos - (send txt set-position pos pos)))] - [select-to-beginning-of-line - (λ (txt event) - (define pos (find-beginning-of-line txt)) - (when pos - (send txt extend-position pos)))] - - - [normalize-unicode-ascii-art-box - (λ (txt evt) - (define start (send txt get-start-position)) - (when (= start (send txt get-end-position)) - (normalize-unicode-ascii-art-box txt start) - (send txt set-position start)))] - - [widen-unicode-ascii-art-box - (λ (txt evt) - (define start (send txt get-start-position)) - (when (= start (send txt get-end-position)) - (widen-unicode-ascii-art-box txt start)))] - - [center-in-unicode-ascii-art-box - (λ (txt evt) - (define start (send txt get-start-position)) - (when (= start (send txt get-end-position)) - (center-in-unicode-ascii-art-box txt start)))]) - - (λ (kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f]) - (let* ([map (λ (key func) - (send kmap map-function key func))] - [map-meta (λ (key func) - (send-map-function-meta kmap key func - (regexp-match? has-control-regexp key) - #:alt-as-meta-keymap alt-as-meta-keymap))] - [add (λ (name func) - (send kmap add-function name func))] - [add-m (λ (name func) - (send kmap add-function name func) - (when alt-as-meta-keymap - (send alt-as-meta-keymap add-function name func)))]) - - ; Map names to keyboard functions - - (for-each - (λ (c) - (unless (equal? c #\space) - (add (format "insert ~a" c) - (λ (txt evt) (send txt insert c))))) - (string->list (string-append greek-letters Greek-letters))) - - (add "normalize-unicode-ascii-art-box" normalize-unicode-ascii-art-box) - (add "widen-unicode-ascii-art-box" widen-unicode-ascii-art-box) - (add "center-in-unicode-ascii-art-box" center-in-unicode-ascii-art-box) - (add "shift-focus" (shift-focus values)) - (add "shift-focus-backwards" (shift-focus reverse)) - - (add "TeX compress" TeX-compress) - (add "newline" newline) - (add-m "down-into-embedded-editor" down-into-embedded-editor) - (add-m "up-out-of-embedded-editor" up-out-of-embedded-editor) - (add-m "forward-to-next-embedded-editor" forward-to-next-embedded-editor) - (add-m "back-to-prev-embedded-editor" back-to-prev-embedded-editor) - - (add-m "toggle-overwrite (when enabled in prefs)" toggle-overwrite) - - (add "exit" (λ (edit event) - (let ([frame (send edit get-frame)]) - (if (and frame - (is-a? frame frame:standard-menus<%>)) - (send frame file-menu:quit) - (bell))))) - - (add "ring-bell" ring-bell) - - - (add "toggle-anchor" toggle-anchor) - (add "center-view-on-line" center-view-on-line) - (add-m "collapse-space" collapse-space) - (add "remove-space" remove-space) - (add "collapse-newline" collapse-newline) - (add "open-line" open-line) - (add "transpose-chars" transpose-chars) - (add-m "transpose-words" transpose-words) - (add-m "capitalize-word" capitalize-word) - (add-m "upcase-word" upcase-word) - (add-m "downcase-word" downcase-word) - (add-m "kill-word" kill-word) - (add-m "backward-kill-word" backward-kill-word) - - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (add-m (string-append "command-repeat-" s) - (make-make-repeater n)) - (loop (sub1 n))))) - - (add "keyboard-macro-run-saved" do-macro) - (add "keyboard-macro-start-record" start-macro) - (add "keyboard-macro-end-record" end-macro) - - (add-m "copy-clipboard" mouse-copy-clipboard) - (add-m "copy-clipboard/disable-anchor" mouse-copy-clipboard/disable-anchor) - (add-m "cut-clipboard" mouse-cut-clipboard) - (add-m "paste-clipboard" mouse-paste-clipboard) - (add-m "copy-click-region" copy-click-region) - (add-m "cut-click-region" cut-click-region) - (add-m "paste-click-region" paste-click-region) - (add-m "select-click-word" select-click-word) - (add-m "select-click-line" select-click-line) - - (add-m "goto-line" goto-line) - - (add "delete-key" delete-key) - - (add "mouse-popup-menu" mouse-popup-menu) - - (add "make-read-only" make-read-only) - - (add "beginning-of-line" beginning-of-line) - (add "select-to-beginning-of-line" select-to-beginning-of-line) - - ; Map keys to functions - - (let ([setup-mappings - (λ (greek-chars shift?) - (let loop ([i 0]) - (when (< i (string-length greek-chars)) - (let ([greek-char (string-ref greek-chars i)]) - (unless (equal? greek-char #\space) - (let ([roman-char - (integer->char - (+ (char->integer #\a) i))]) - (map (format "a:g;~a~a" - (if shift? "s:" "") - roman-char) - (format "insert ~a" greek-char)) - (map (format "~~c:m:x;c:g;~a~a" - (if shift? "s:" "") - roman-char) - (format "insert ~a" greek-char)) - (map (format "c:x;c:g;~a~a" - (if shift? "s:" "") - roman-char) - (format "insert ~a" greek-char))))) - (loop (+ i 1)))))]) - (setup-mappings greek-letters #f) - (setup-mappings Greek-letters #t)) - - (map "c:x;r;a" "normalize-unicode-ascii-art-box") - (map "c:x;r;w" "widen-unicode-ascii-art-box") - (map "c:x;r;c" "center-in-unicode-ascii-art-box") - - (map "~m:c:\\" "TeX compress") - (map "~c:m:\\" "TeX compress") - (map "c:x;t" "TeX compress") - - (map "c:j" "newline") - - (map-meta "c:down" "down-into-embedded-editor") - (map "a:c:down" "down-into-embedded-editor") - (map-meta "c:up" "up-out-of-embedded-editor") - (map "a:c:up" "up-out-of-embedded-editor") - (map-meta "c:right" "forward-to-next-embedded-editor") - (map "a:c:right" "forward-to-next-embedded-editor") - (map-meta "c:left" "back-to-prev-embedded-editor") - (map "a:c:left" "back-to-prev-embedded-editor") - - (map "c:c;c:g" "ring-bell") - - (map "c:p" "previous-line") - (map "up" "previous-line") - (map "s:c:p" "select-up") - (map "s:up" "select-up") - - (map "c:n" "next-line") - (map "down" "next-line") - (map "s:c:n" "select-down") - (map "s:down" "select-down") - - (map "c:e" "end-of-line") - (map "d:right" "end-of-line") - (map "end" "end-of-line") - (map "s:end" "select-to-end-of-line") - (map "s:c:e" "select-to-end-of-line") - (map "s:d:right" "select-to-end-of-line") - - (map "c:a" "beginning-of-line") - (map "d:left" "beginning-of-line") - (map "home" "beginning-of-line") - (map "s:home" "select-to-beginning-of-line") - (map "s:c:a" "select-to-beginning-of-line") - (map "s:d:left" "select-to-beginning-of-line") - (map "c:f" "forward-character") - (map "right" "forward-character") - (map "s:c:f" "forward-select") - (map "s:right" "forward-select") - - (map "c:b" "backward-character") - (map "left" "backward-character") - (map "s:c:b" "backward-select") - (map "s:left" "backward-select") - - (map-meta "f" "forward-word") - (map "c:right" "forward-word") - (map-meta "s:f" "forward-select-word") - (map "c:s:right" "forward-select-word") - - (map-meta "b" "backward-word") - - (map "c:left" "backward-word") - (map-meta "s:b" "backward-select-word") - (map "c:s:left" "backward-select-word") - - (map-meta "<" "beginning-of-file") - (map "d:up" "beginning-of-file") - (map "c:home" "beginning-of-file") - (map "s:c:home" "select-to-beginning-of-file") - (map "s:d:up" "select-to-beginning-of-file") - - (map-meta ">" "end-of-file") - (map "d:down" "end-of-file") - (map "c:end" "end-of-file") - (map "s:c:end" "select-to-end-of-file") - (map "s:d:down" "select-to-end-of-file") - - (map "c:v" "next-page") - (map "pagedown" "next-page") - (map "c:down" "next-page") - (map "s:c:v" "select-page-down") - (map "s:pagedown" "select-page-down") - (map "s:c:down" "select-page-down") - - (map-meta "v" "previous-page") - (map "pageup" "previous-page") - (map "c:up" "previous-page") - (map-meta "s:v" "select-page-up") - (map "s:pageup" "select-page-up") - (map "s:c:up" "select-page-up") - - (map "c:h" "delete-previous-character") - (map "c:d" "delete-next-character") - (map "del" "delete-key") - - (map-meta "d" "kill-word") - (map-meta "del" "kill-word") - (map-meta "backspace" "backward-kill-word") - (map-meta "c" "capitalize-word") - (map-meta "u" "upcase-word") - (map-meta "l" "downcase-word") - - (map "c:l" "center-view-on-line") - - (map "c:k" "delete-to-end-of-line") - (map "c:y" "paste-clipboard") - (map-meta "y" "paste-next") - (map "a:v" "paste-clipboard") - (map "d:v" "paste-clipboard") - (map "c:_" "undo") - (map "c:/" "undo") - (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange - (map "c:+" "redo") - (map "a:z" "undo") - (map "d:z" "undo") - (map "c:x;u" "undo") - (map "c:w" "cut-clipboard") - (map "a:x" "cut-clipboard") - (map "d:x" "cut-clipboard") - (map-meta "w" "copy-clipboard/disable-anchor") - (map "a:c" "copy-clipboard") - (map "d:c" "copy-clipboard") - - (map "s:delete" "cut-clipboard") - (map "c:insert" "copy-clipboard") - (map "s:insert" "paste-clipboard") - - (map-meta "space" "collapse-space") - (when (eq? (system-type) 'macosx) - (map "a:space" "collapse-space")) - ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards. - (map "c:x;c:o" "collapse-newline") - (map "c:o" "open-line") - (map "c:t" "transpose-chars") - (map-meta "t" "transpose-words") - - (map "c:space" "toggle-anchor") - - (map "insert" "toggle-overwrite (when enabled in prefs)") - (map-meta "o" "toggle-overwrite (when enabled in prefs)") - - (map-meta "g" "goto-line") - - (map "c:u" "command-repeat-0") - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (map-meta s (string-append "command-repeat-" s)) - (loop (sub1 n))))) - - (map "c:x;e" "keyboard-macro-run-saved") - (map "c:x;(" "keyboard-macro-start-record") - (map "c:x;)" "keyboard-macro-end-record") - - (map "leftbuttontriple" "select-click-line") - (map "leftbuttondouble" "select-click-word") - - ;; the "roller ball" mice map clicking the ball to button 2. - (unless (eq? (system-type) 'windows) - (map "middlebutton" "paste-click-region")) - - (map ":rightbuttonseq" "mouse-popup-menu") - - (map "c:c;c:r" "make-read-only") - - (map "c:x;o" "shift-focus") - (map "c:x;p" "shift-focus-backwards") - (map "c:f6" "shift-focus") - (map "a:tab" "shift-focus") - (map "a:s:tab" "shift-focus-backwards"))))) + (define make-meta-prefix-list keymap:make-meta-prefix-list) + + (define send-map-function-meta keymap:send-map-function-meta) + + (define region-click keymap:region-click) + (define add-to-right-button-menu keymap:add-to-right-button-menu) + (define add-to-right-button-menu/before keymap:add-to-right-button-menu/before) + + (define (call/text-keymap-initializer thunk) + (let ([ctki (current-text-keymap-initializer)]) + (parameterize ([current-text-keymap-initializer + (λ (keymap) + (send keymap chain-to-keymap global #t) + (ctki keymap))]) + (thunk)))) + + (define (setup-global kmap #:alt-as-meta-keymap [alt-as-meta-keymap #f]) + (keymap:setup-global kmap #:alt-as-meta-keymap alt-as-meta-keymap) + (define (goto-line edit event) + (define num-str + (call/text-keymap-initializer + (λ () + (get-text-from-user + (string-constant goto-line) + (string-constant goto-line))))) + (when (string? num-str) + (define possible-num (string->number num-str)) + (define line-num (and possible-num (inexact->exact possible-num))) + (cond + [(and (number? line-num) + (integer? line-num) + (<= 1 line-num (+ (send edit last-paragraph) 1))) + (define pos (send edit paragraph-start-position (sub1 line-num))) + (send edit set-position pos)] + [else + (message-box + (string-constant goto-line) + (format + (string-constant goto-line-invalid-number) + num-str + (+ (send edit last-line) 1)))])) + #t) + + (let ([add-m (λ (name func) + (send kmap add-function name func) + (when alt-as-meta-keymap + (send alt-as-meta-keymap add-function name func)))] + [map-meta (λ (key func) + (keymap:send-map-function-meta kmap key func + (regexp-match? has-control-regexp key) + #:alt-as-meta-keymap alt-as-meta-keymap))]) + (add-m "goto-line" goto-line) + (map-meta "g" "goto-line"))) + (define setup-search (let* ([send-frame (λ (invoke-method) @@ -1542,372 +577,5 @@ (send search chain-to-keymap search-alt-as-meta #f))) (preferences:add-callback 'framework:alt-as-meta (λ (p v) (adjust-alt-as-meta v))) - (adjust-alt-as-meta (preferences:get 'framework:alt-as-meta)) - - (define (call/text-keymap-initializer thunk) - (let ([ctki (current-text-keymap-initializer)]) - (parameterize ([current-text-keymap-initializer - (λ (keymap) - (send keymap chain-to-keymap global #t) - (ctki keymap))]) - (thunk)))) + (adjust-alt-as-meta (preferences:get 'framework:alt-as-meta))) - (define (region-click text event f) - (region-click/internal text event - (λ (click-pos eol start end) (f click-pos eol)))) - - (define (region-click/internal text event f) - (when (and (is-a? event mouse-event%) - (send event button-down?) - (is-a? text text%)) - (define x-box (box (send event get-x))) - (define y-box (box (send event get-y))) - (define eol-box (box #f)) - (send text global-to-local x-box y-box) - (define click-pos (send text find-position - (unbox x-box) - (unbox y-box) - eol-box)) - (define start-pos (send text get-start-position)) - (define end-pos (send text get-end-position)) - (define eol (unbox eol-box)) - (if (< start-pos click-pos) - (f click-pos eol start-pos click-pos) - (f click-pos eol click-pos end-pos))))) - -(define (widen-unicode-ascii-art-box t orig-pos) - (define start-pos (scan-for-start-pos t orig-pos)) - (when start-pos - (send t begin-edit-sequence) - (define-values (start-x start-y) (pos->xy t orig-pos)) - (define min-y #f) - (define max-y #f) - (trace-unicode-ascii-art-box - t start-pos #f - (λ (pos x y i-up? i-dn? i-lt? i-rt?) - (when (= x start-x) - (unless min-y - (set! min-y y) - (set! max-y y)) - (set! min-y (min y min-y)) - (set! max-y (max y max-y))))) - (define to-adjust 0) - (for ([y (in-range max-y (- min-y 1) -1)]) - (define-values (pos char) (xy->pos t start-x y)) - (when (< pos start-pos) - (set! to-adjust (+ to-adjust 1))) - (send t insert - (cond - [(member char lt-chars) #\═] - [else #\space]) - pos pos)) - (send t set-position (+ orig-pos to-adjust 1) (+ orig-pos to-adjust 1)) - (send t end-edit-sequence))) - -(define (normalize-unicode-ascii-art-box t pos) - (define start-pos (scan-for-start-pos t pos)) - (when start-pos - (send t begin-edit-sequence) - (trace-unicode-ascii-art-box - t start-pos #f - (λ (pos x y i-up? i-dn? i-lt? i-rt?) - (cond - [(and i-up? i-dn? i-lt? i-rt?) (set-c t pos "╬")] - [(and i-dn? i-lt? i-rt?) (set-c t pos "╦")] - [(and i-up? i-lt? i-rt?) (set-c t pos "╩")] - [(and i-up? i-dn? i-rt?) (set-c t pos "╠")] - [(and i-up? i-dn? i-lt?) (set-c t pos "╣")] - [(and i-up? i-lt?) (set-c t pos "╝")] - [(and i-up? i-rt?) (set-c t pos "╚")] - [(and i-dn? i-lt?) (set-c t pos "╗")] - [(and i-dn? i-rt?) (set-c t pos "╔")] - [(or i-up? i-dn?) (set-c t pos "║")] - [else (set-c t pos "═")]))) - (send t end-edit-sequence))) - -(define (center-in-unicode-ascii-art-box txt insertion-pos) - (define (find-something start-pos inc char-p?) - (define-values (x y) (pos->xy txt start-pos)) - (let loop ([pos start-pos]) - (cond - [(char-p? (send txt get-character pos)) - pos] - [else - (define new-pos (inc pos)) - (cond - [(<= 0 new-pos (send txt last-position)) - (define-values (x2 y2) (pos->xy txt new-pos)) - (cond - [(= y2 y) - (loop new-pos)] - [else #f])] - [else #f])]))) - - (define (adjust-space before-space after-space pos) - (cond - [(< before-space after-space) - (send txt insert (make-string (- after-space before-space) #\space) pos pos)] - [(> before-space after-space) - (send txt delete pos (+ pos (- before-space after-space)))])) - - (define left-bar (find-something insertion-pos sub1 (λ (x) (equal? x #\║)))) - (define right-bar (find-something insertion-pos add1 (λ (x) (equal? x #\║)))) - (when (and left-bar right-bar (< left-bar right-bar)) - (define left-space-edge (find-something (+ left-bar 1) add1 (λ (x) (not (char-whitespace? x))))) - (define right-space-edge (find-something (- right-bar 1) sub1 (λ (x) (not (char-whitespace? x))))) - (when (and left-space-edge right-space-edge) - (define before-left-space-count (- left-space-edge left-bar 1)) - (define before-right-space-count (- right-bar right-space-edge 1)) - (define tot-space (+ before-left-space-count before-right-space-count)) - (define after-left-space-count (floor (/ tot-space 2))) - (define after-right-space-count (ceiling (/ tot-space 2))) - (send txt begin-edit-sequence) - (adjust-space before-right-space-count after-right-space-count (+ right-space-edge 1)) - (adjust-space before-left-space-count after-left-space-count (+ left-bar 1)) - (send txt end-edit-sequence)))) - -(define (trace-unicode-ascii-art-box t start-pos only-double-barred-chars? f) - (define visited (make-hash)) - (let loop ([pos start-pos]) - (unless (hash-ref visited pos #f) - (hash-set! visited pos #t) - (define-values (x y) (pos->xy t pos)) - (define c (send t get-character pos)) - (define-values (up upc) (xy->pos t x (- y 1))) - (define-values (dn dnc) (xy->pos t x (+ y 1))) - (define-values (lt ltc) (xy->pos t (- x 1) y)) - (define-values (rt rtc) (xy->pos t (+ x 1) y)) - (define (interesting-dir? dir-c dir-chars) - (or (and (not only-double-barred-chars?) - (member dir-c adjustable-chars) - (member c dir-chars)) - (and (member dir-c double-barred-chars) - (member c double-barred-chars)))) - (define i-up? (interesting-dir? upc up-chars)) - (define i-dn? (interesting-dir? dnc dn-chars)) - (define i-lt? (interesting-dir? ltc lt-chars)) - (define i-rt? (interesting-dir? rtc rt-chars)) - (f pos x y i-up? i-dn? i-lt? i-rt?) - (when i-up? (loop up)) - (when i-dn? (loop dn)) - (when i-lt? (loop lt)) - (when i-rt? (loop rt))))) - -(define (scan-for-start-pos t pos) - (define-values (x y) (pos->xy t pos)) - (findf - (λ (p) (adj? t p)) - (for*/list ([xadj '(0 -1)] - [yadj '(0 -1 1)]) - (define-values (d dc) (xy->pos t (+ x xadj) (+ y yadj))) - d))) - -(define (adj? t pos) - (and pos - (member (send t get-character pos) - adjustable-chars))) - -(define (set-c t pos s) - (unless (equal? (string-ref s 0) (send t get-character pos)) - (send t delete pos (+ pos 1)) - (send t insert s pos pos))) - -(define (pos->xy text pos) - (define para (send text position-paragraph pos)) - (define start (send text paragraph-start-position para)) - (values (- pos start) para)) - -(define (xy->pos text x y) - (cond - [(and (<= 0 x) (<= 0 y (send text last-paragraph))) - (define para-start (send text paragraph-start-position y)) - (define para-end (send text paragraph-end-position y)) - (define pos (+ para-start x)) - (define res-pos - (and (< pos para-end) - ;; the newline at the end of the - ;; line is not on the line, so use this guard - pos)) - (if res-pos - (values res-pos (send text get-character res-pos)) - (values #f #f))] - [else (values #f #f)])) - -(module+ test - (require rackunit - racket/gui/base) - (define sa string-append) - - (define (first-value-xy->pos a b c) - (define-values (d e) (xy->pos a b c)) - d) - - (let ([t (new text%)]) - (send t insert (sa "abc\n" - "d\n" - "ghi\n")) - (check-equal? (first-value-xy->pos t 0 0) 0) - (check-equal? (first-value-xy->pos t 1 0) 1) - (check-equal? (first-value-xy->pos t 0 1) 4) - (check-equal? (first-value-xy->pos t 3 0) #f) - (check-equal? (first-value-xy->pos t 0 3) #f) - (check-equal? (first-value-xy->pos t 1 1) #f) - (check-equal? (first-value-xy->pos t 2 1) #f) - (check-equal? (first-value-xy->pos t 0 2) 6) - (check-equal? (first-value-xy->pos t 1 2) 7) - (check-equal? (first-value-xy->pos t 2 -1) #f) - (check-equal? (first-value-xy->pos t -1 0) #f) - (check-equal? (first-value-xy->pos t 2 2) 8) - (check-equal? (first-value-xy->pos t 2 3) #f)) - - (let ([t (new text%)]) - (send t insert (sa "abc\n" - "d\n" - "ghi")) - (check-equal? (first-value-xy->pos t 2 2) 8) - (check-equal? (first-value-xy->pos t 2 3) #f)) - - (let ([t (new text%)]) - (send t insert (string-append "+-+\n" - "| |\n" - "+-+\n")) - (normalize-unicode-ascii-art-box t 0) - (check-equal? (send t get-text) - (string-append - "╔═╗\n" - "║ ║\n" - "╚═╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append "+=+\n" - "| |\n" - "+=+\n")) - (normalize-unicode-ascii-art-box t 0) - (check-equal? (send t get-text) - (string-append - "╔═╗\n" - "║ ║\n" - "╚═╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append "+-+-+\n" - "| | |\n" - "+-+-+\n" - "| | |\n" - "+-+-+\n")) - (normalize-unicode-ascii-art-box t 0) - (check-equal? (send t get-text) - (string-append - "╔═╦═╗\n" - "║ ║ ║\n" - "╠═╬═╣\n" - "║ ║ ║\n" - "╚═╩═╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append - "╔═══╗\n" - "║ - ║\n" - "╚═══╝\n")) - - (normalize-unicode-ascii-art-box t 0) - (check-equal? (send t get-text) - (string-append - "╔═══╗\n" - "║ - ║\n" - "╚═══╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append - "╔═╦═╗\n" - "║ ║ ║\n" - "╠═╬═╣\n" - "║ ║ ║\n" - "╚═╩═╝\n")) - (send t set-position 1 1) - (widen-unicode-ascii-art-box t 1) - (check-equal? (send t get-start-position) 2) - (check-equal? (send t get-text) - (string-append - "╔══╦═╗\n" - "║ ║ ║\n" - "╠══╬═╣\n" - "║ ║ ║\n" - "╚══╩═╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append - "╔═╦═╗\n" - "║ ║ ║\n" - "╠═╬═╣\n" - "║ ║ ║\n" - "╚═╩═╝\n")) - (send t set-position 8 8) - (widen-unicode-ascii-art-box t 8) - (check-equal? (send t get-start-position) 10) - (check-equal? (send t get-text) - (string-append - "╔══╦═╗\n" - "║ ║ ║\n" - "╠══╬═╣\n" - "║ ║ ║\n" - "╚══╩═╝\n"))) - - (let ([t (new text%)]) - (send t insert (string-append - "╔═╦═╗\n" - "║ ║ ║\n" - "╠═╬═╣\n" - "║ ║ ║\n")) - (send t set-position 8 8) - (widen-unicode-ascii-art-box t 8) - (check-equal? (send t get-text) - (string-append - "╔══╦═╗\n" - "║ ║ ║\n" - "╠══╬═╣\n" - "║ ║ ║\n"))) - - (let ([t (new text%)]) - (send t insert "║ x ║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║ x ║\n")) - - (let ([t (new text%)]) - (send t insert "║x ║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║ x ║\n")) - - (let ([t (new text%)]) - (send t insert "║ x║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║ x ║\n")) - - (let ([t (new text%)]) - (send t insert "║abcde║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║abcde║\n")) - - (let ([t (new text%)]) - (send t insert "║║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║║\n")) - - (let ([t (new text%)]) - (send t insert "║abcde \n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - "║abcde \n")) - - (let ([t (new text%)]) - (send t insert " abcde║\n") - (center-in-unicode-ascii-art-box t 1) - (check-equal? (send t get-text) - " abcde║\n")) - - ) diff --git a/gui-lib/framework/private/text.rkt b/gui-lib/framework/private/text.rkt index 75293c56..57ddfd76 100644 --- a/gui-lib/framework/private/text.rkt +++ b/gui-lib/framework/private/text.rkt @@ -6,6 +6,7 @@ racket/path racket/math "sig.rkt" + "interfaces.rkt" "../gui-utils.rkt" "../preferences.rkt" "autocomplete.rkt" @@ -85,23 +86,7 @@ (values register-port-name! lookup-port-name))) -(define basic<%> - (interface (editor:basic<%> (class->interface text%)) - highlight-range - unhighlight-range - unhighlight-ranges - unhighlight-ranges/key - get-highlighted-ranges - get-styles-fixed - get-fixed-style - set-styles-fixed - move/copy-to-edit - initial-autowrap-bitmap - get-port-name - port-name-matches? - after-set-port-unsaved-name - set-port-unsaved-name - get-start-of-line)) +(define basic<%> text:basic<%>) (define highlight-range-mixin (mixin (editor:basic<%> (class->interface text%)) ()