6fff8a3030
popup menu Extends append-editor-operation-menu-items so that when you pass an editor and a position, it checks to see if that spot has a non-string% snip and, if so, copies that one position (or cuts it, depending). Then, use that extension in DrRacket closes PR 12791
777 lines
32 KiB
Racket
777 lines
32 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/list
|
|
racket/file
|
|
racket/path
|
|
(for-syntax racket/base)
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: racket/snip/private/style)
|
|
(prefix-in wx: racket/snip/private/snip)
|
|
(prefix-in wx: "wxme/keymap.rkt")
|
|
(prefix-in wx: "wxme/editor.rkt")
|
|
(prefix-in wx: "wxme/text.rkt")
|
|
(prefix-in wx: "wxme/pasteboard.rkt")
|
|
(prefix-in wx: "wxme/editor-snip.rkt")
|
|
(prefix-in wx: (only-in "wxme/cycle.rkt"
|
|
set-extended-editor-snip%!
|
|
set-extended-text%!
|
|
set-extended-pasteboard%!))
|
|
"seqcontract.rkt"
|
|
"lock.rkt"
|
|
"check.rkt"
|
|
"const.rkt"
|
|
"helper.rkt"
|
|
"cycle.rkt"
|
|
"wx.rkt"
|
|
"wxtop.rkt"
|
|
"wxitem.rkt"
|
|
"wxcanvas.rkt"
|
|
"mrwindow.rkt"
|
|
"mrtop.rkt"
|
|
"mrcanvas.rkt"
|
|
"mrpopup.rkt"
|
|
"mrmenuintf.rkt"
|
|
"mrmenu.rkt")
|
|
|
|
(provide editor<%>
|
|
text%
|
|
pasteboard%
|
|
editor-snip%
|
|
current-text-keymap-initializer
|
|
append-editor-operation-menu-items
|
|
append-editor-font-menu-items)
|
|
|
|
(define editor<%>
|
|
(interface (wx:editor<%>)
|
|
get-canvases
|
|
get-active-canvas set-active-canvas
|
|
get-canvas
|
|
add-canvas remove-canvas
|
|
auto-wrap get-max-view-size
|
|
save-file))
|
|
|
|
(define-local-member-name
|
|
-format-filter
|
|
-format-filter/save
|
|
-get-current-format
|
|
-get-file-format
|
|
-set-file-format
|
|
-set-position
|
|
-set-format)
|
|
|
|
(define (check-format who format)
|
|
(unless (memq format '(guess standard text text-force-cr same copy))
|
|
(raise-argument-error (who->name who)
|
|
"(or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)"
|
|
format)))
|
|
|
|
(define-syntax (augmentize stx)
|
|
(syntax-case stx ()
|
|
[(_ (result id arg ...) ...)
|
|
#'(begin
|
|
(define/overment (id arg ...)
|
|
(and (super id arg ...)
|
|
(inner result id arg ...)))
|
|
...)]))
|
|
|
|
(define (make-editor-buffer% % can-wrap? get-editor%)
|
|
; >>> This class is instantiated directly by the end-user <<<
|
|
(class* % (editor<%> internal-editor<%>)
|
|
(init-rest args)
|
|
(rename-super [super-get-view-size get-view-size]
|
|
[super-begin-edit-sequence begin-edit-sequence]
|
|
[super-end-edit-sequence end-edit-sequence]
|
|
[super-insert-port insert-port]
|
|
[super-save-port save-port]
|
|
[super-erase erase]
|
|
[super-clear-undos clear-undos]
|
|
[super-get-load-overwrites-styles get-load-overwrites-styles]
|
|
[super-get-filename get-filename])
|
|
(inherit get-max-width set-max-width get-admin
|
|
get-keymap get-style-list
|
|
set-modified set-filename
|
|
get-file put-file
|
|
get-max-undo-history)
|
|
(define canvases null)
|
|
(define active-canvas #f)
|
|
(define auto-set-wrap? #f)
|
|
(define use-text-mode? #t)
|
|
(private*
|
|
[max-view-size
|
|
(lambda ()
|
|
(let ([wb (box 0)]
|
|
[hb (box 0)])
|
|
(super-get-view-size wb hb)
|
|
(unless (or (null? canvases) (null? (cdr canvases)))
|
|
(for-each
|
|
(lambda (canvas)
|
|
(send canvas call-as-primary-owner
|
|
(lambda ()
|
|
(let ([wb2 (box 0)]
|
|
[hb2 (box 0)])
|
|
(super-get-view-size wb2 hb2)
|
|
(set-box! wb (max (unbox wb) (unbox wb2)))
|
|
(set-box! hb (max (unbox hb) (unbox hb2)))))))
|
|
canvases))
|
|
(values (unbox wb) (unbox hb))))])
|
|
(public*
|
|
[-format-filter (lambda (f) f)]
|
|
[-format-filter/save (lambda (f) f)]
|
|
[-set-file-format (lambda (f) (void))]
|
|
[-set-position (lambda () (void))]
|
|
[-get-file-format (lambda () 'standard)])
|
|
|
|
(override*
|
|
[insert-file
|
|
(lambda (file [format 'guess] [show-errors? #t])
|
|
(let ([who '(method editor<%> insert-file)])
|
|
(check-path who file)
|
|
(check-format who format))
|
|
(do-load-file file format #f))]
|
|
|
|
[load-file
|
|
(lambda ([file #f] [format 'guess] [show-errors? #t])
|
|
(do-load-file file format #t))])
|
|
|
|
(public*
|
|
[use-file-text-mode
|
|
(case-lambda
|
|
[() use-text-mode?]
|
|
[(v?) (set! use-text-mode? (and v? #t))])])
|
|
|
|
(private*
|
|
[do-load-file
|
|
(lambda (file format load?)
|
|
(let ([who '(method editor<%> load-file)])
|
|
(unless (equal? file "")
|
|
(check-path/false who file))
|
|
(check-format who format))
|
|
(let* ([temp-filename?-box (box #f)]
|
|
[old-filename (super-get-filename temp-filename?-box)])
|
|
(let* ([file (cond
|
|
[(or (not (path-string? file))
|
|
(equal? file ""))
|
|
(if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
|
|
(let ([path (if old-filename
|
|
(path-only old-filename)
|
|
#f)])
|
|
(get-file path))
|
|
old-filename)]
|
|
[(path? file) file]
|
|
[else (string->path file)])])
|
|
(and
|
|
file
|
|
(or (not load?)
|
|
(can-load-file? file (-format-filter format)))
|
|
(begin
|
|
(or (not load?)
|
|
(on-load-file file (-format-filter format)))
|
|
(let ([port #f]
|
|
[finished? #f])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(set! port (open-input-file file))
|
|
(wx:begin-busy-cursor)
|
|
(super-begin-edit-sequence)
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(when load?
|
|
(super-erase)
|
|
(unless (and (not (unbox temp-filename?-box))
|
|
(equal? file old-filename))
|
|
(set-filename file #f)))
|
|
(let ([format (if (eq? format 'same)
|
|
(-get-file-format)
|
|
format)])
|
|
(let ([new-format
|
|
(with-handlers ([values (lambda (x)
|
|
(set-filename #f #f)
|
|
(raise x))])
|
|
(super-insert-port port
|
|
(-format-filter format)
|
|
(and load?
|
|
(super-get-load-overwrites-styles))))])
|
|
(close-input-port port) ; close as soon as possible
|
|
(when load?
|
|
(-set-file-format new-format)
|
|
(-set-position))))) ; text% only
|
|
(lambda ()
|
|
(super-end-edit-sequence)
|
|
(wx:end-busy-cursor)))
|
|
(when load?
|
|
(super-clear-undos)
|
|
(set-modified #f))
|
|
(set! finished? #t)
|
|
#t)
|
|
(lambda ()
|
|
;; In case it wasn't closed before:
|
|
(when port (close-input-port port))
|
|
(when load?
|
|
(after-load-file finished?))))))))))])
|
|
(public*
|
|
[save-file
|
|
(lambda ([file #f] [format 'same] [show-errors? #t])
|
|
(let ([who '(method editor<%> save-file)])
|
|
(unless (equal? file "")
|
|
(check-path/false who file))
|
|
(check-format who format))
|
|
(let* ([temp-filename?-box (box #f)]
|
|
[old-filename (super-get-filename temp-filename?-box)])
|
|
(let* ([file (cond
|
|
[(or (not (path-string? file))
|
|
(equal? file ""))
|
|
(if (or (equal? file "") (not old-filename) (unbox temp-filename?-box))
|
|
(let ([path (if old-filename
|
|
(path-only old-filename)
|
|
#f)])
|
|
(put-file path (and old-filename
|
|
(file-name-from-path old-filename))))
|
|
old-filename)]
|
|
[(path? file) file]
|
|
[else (string->path file)])]
|
|
[f-format (-format-filter/save format)])
|
|
(and
|
|
file
|
|
(can-save-file? file f-format)
|
|
(begin
|
|
(on-save-file file f-format)
|
|
(let* ([actual-format (if (memq f-format '(copy same))
|
|
(-get-file-format)
|
|
f-format)]
|
|
[text? (memq actual-format '(text text-force-cr))]
|
|
[text-mode? (and text? use-text-mode?)])
|
|
(let ([port #f]
|
|
[finished? #f])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(set! port (open-output-file file
|
|
#:mode (if text-mode? 'text 'binary)
|
|
#:exists 'truncate/replace))
|
|
(wx:file-creator-and-type file #"mReD" (if text? #"TEXT" #"WXME"))
|
|
(wx:begin-busy-cursor)
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(super-save-port port format #t)
|
|
(close-output-port port) ; close as soon as possible
|
|
(unless (or (eq? format 'copy)
|
|
(and (not (unbox temp-filename?-box))
|
|
(equal? file old-filename)))
|
|
(set-filename file #f))
|
|
(unless (eq? format 'copy)
|
|
(-set-file-format actual-format))) ; text% only
|
|
(lambda ()
|
|
(wx:end-busy-cursor)))
|
|
(unless (eq? format 'copy)
|
|
(set-modified #f))
|
|
(set! finished? #t)
|
|
#t)
|
|
(lambda ()
|
|
;; In case it wasn't closed before:
|
|
(when port (close-output-port port))
|
|
(after-save-file finished?))))))))))])
|
|
|
|
(public*
|
|
[get-canvases (entry-point (lambda () (map wx->mred canvases)))]
|
|
[get-active-canvas (entry-point (lambda () (and active-canvas (wx->mred active-canvas))))]
|
|
[get-canvas
|
|
(entry-point
|
|
(lambda ()
|
|
(let ([c (or active-canvas
|
|
(and (not (null? canvases))
|
|
(car canvases)))])
|
|
(and c (wx->mred c)))))]
|
|
[set-active-canvas
|
|
(entry-point
|
|
(lambda (new-canvas)
|
|
(check-instance '(method editor<%> set-active-canvas) editor-canvas% 'editor-canvas% #t new-canvas)
|
|
(set! active-canvas (mred->wx new-canvas))))]
|
|
|
|
[add-canvas
|
|
(entry-point
|
|
(lambda (new-canvas)
|
|
(check-instance '(method editor<%> add-canvas) editor-canvas% 'editor-canvas% #f new-canvas)
|
|
(let ([new-canvas (mred->wx new-canvas)])
|
|
(unless (memq new-canvas canvases)
|
|
(set! canvases (cons new-canvas canvases))))))]
|
|
|
|
[remove-canvas
|
|
(entry-point
|
|
(lambda (old-canvas)
|
|
(check-instance '(method editor<%> remove-canvas) editor-canvas% 'editor-canvas% #f old-canvas)
|
|
(let ([old-canvas (mred->wx old-canvas)])
|
|
(when (eq? old-canvas active-canvas)
|
|
(set! active-canvas #f))
|
|
(set! canvases (remq old-canvas canvases)))))]
|
|
|
|
[auto-wrap (case-lambda
|
|
[() auto-set-wrap?]
|
|
[(on?) (as-entry
|
|
(lambda ()
|
|
(set! auto-set-wrap? (and on? #t))
|
|
(as-exit
|
|
(lambda ()
|
|
(if on?
|
|
(on-display-size)
|
|
(set-max-width 'none))))))])]
|
|
[get-max-view-size (entry-point (lambda () (max-view-size)))])
|
|
(override*
|
|
[copy-self
|
|
(lambda () (let ([e (make-object (get-editor%))])
|
|
(copy-self-to e)
|
|
e))]
|
|
[copy-self-to
|
|
(lambda (e)
|
|
(super copy-self-to e)
|
|
(send e auto-wrap auto-set-wrap?))])
|
|
|
|
(overment*
|
|
[on-display-size
|
|
(entry-point
|
|
(lambda ()
|
|
(as-exit (lambda () (super on-display-size)))
|
|
(when (as-exit (lambda () (get-admin)))
|
|
(when (and can-wrap? auto-set-wrap?)
|
|
(let-values ([(current-width) (as-exit (lambda () (get-max-width)))]
|
|
[(new-width new-height) (max-view-size)])
|
|
(when (and (not (equal? current-width new-width))
|
|
(< 0 new-width))
|
|
(as-exit (lambda () (set-max-width new-width)))))))
|
|
(as-exit (lambda () (inner (void) on-display-size)))))])
|
|
|
|
(augmentize ((void) on-change)
|
|
((void) on-snip-modified snip x)
|
|
(#t can-save-file? p t)
|
|
((void) on-save-file p t)
|
|
((void) after-save-file t)
|
|
(#t can-load-file? p t)
|
|
((void) on-load-file p t)
|
|
((void) after-load-file t)
|
|
((void) on-edit-sequence)
|
|
((void) after-edit-sequence))
|
|
|
|
(private*
|
|
[sp (lambda (x y z f b? eps?)
|
|
;; let super method report z errors:
|
|
(let ([zok? (memq z '(standard postscript))])
|
|
(when zok?
|
|
(check-top-level-parent/false '(method editor<%> print) f))
|
|
(let ([p (and zok? f (mred->wx f))])
|
|
(as-exit (lambda () (super print x y z p b? eps?))))))])
|
|
|
|
(override*
|
|
[print
|
|
(entry-point
|
|
(case-lambda
|
|
[() (sp #t #t 'standard #f #t #f)]
|
|
[(x) (sp x #t 'standard #f #t #f)]
|
|
[(x y) (sp x y 'standard #f #t #f)]
|
|
[(x y z) (sp x y z #f #t #f)]
|
|
[(x y z f) (sp x y z f #t #f)]
|
|
[(x y z f b?) (sp x y z f b? #f)]
|
|
[(x y z f b? eps?) (sp x y z f b? eps?)]))]
|
|
|
|
[on-new-box
|
|
(entry-point
|
|
(lambda (type)
|
|
(unless (memq type '(text pasteboard))
|
|
(raise-argument-error (who->name '(method editor<%> on-new-box)) "(or/c 'text 'pasteboard)" type))
|
|
(make-object editor-snip%
|
|
(let ([e (make-object (cond
|
|
[(eq? type 'pasteboard) pasteboard%]
|
|
[else text%]))])
|
|
(send e set-keymap (get-keymap))
|
|
(send e set-style-list (get-style-list))
|
|
(send e set-max-undo-history (get-max-undo-history))
|
|
e))))])
|
|
|
|
(apply super-make-object args)))
|
|
|
|
(define text%
|
|
(class (lock-contract-mixin
|
|
(es-contract-mixin
|
|
(make-editor-buffer% wx:text% #t (lambda () text%))))
|
|
(init [line-spacing 1.0]
|
|
[tab-stops null]
|
|
[(aw? auto-wrap) #f])
|
|
(rename-super [super-get-file-format get-file-format]
|
|
[super-set-file-format set-file-format]
|
|
[super-set-position set-position]
|
|
[super-auto-wrap auto-wrap])
|
|
(override*
|
|
[-get-file-format (lambda ()
|
|
(super-get-file-format))]
|
|
[-set-file-format (lambda (format)
|
|
(super-set-file-format format))]
|
|
[-set-position (lambda ()
|
|
(super-set-position 0 0))])
|
|
|
|
(augmentize (#t can-insert? s e)
|
|
((void) on-insert s e)
|
|
((void) after-insert s e)
|
|
(#t can-delete? s e)
|
|
((void) on-delete s e)
|
|
((void) after-delete s e)
|
|
(#t can-change-style? s e)
|
|
((void) on-change-style s e)
|
|
((void) after-change-style s e)
|
|
((void) after-set-position)
|
|
(#t can-set-size-constraint?)
|
|
((void) on-set-size-constraint)
|
|
((void) after-set-size-constraint)
|
|
((void) after-split-snip s)
|
|
((void) after-merge-snips s)
|
|
((void) on-reflow))
|
|
|
|
(super-make-object line-spacing tab-stops)
|
|
(when aw?
|
|
(super-auto-wrap #t))))
|
|
|
|
(define pasteboard%
|
|
(class (es-contract-mixin (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%)))
|
|
(override*
|
|
[-format-filter (lambda (f) 'standard)]
|
|
[-format-filter/save (lambda (f) (if (eq? f 'copy)
|
|
f
|
|
'standard))])
|
|
(augmentize (#t can-insert? s s2 x y)
|
|
((void) on-insert s s2 x y)
|
|
((void) after-insert s s2 x y)
|
|
(#t can-delete? s)
|
|
((void) on-delete s)
|
|
((void) after-delete s)
|
|
(#t can-move-to? s x y ?)
|
|
((void) on-move-to s x y ?)
|
|
((void) after-move-to s x y ?)
|
|
(#t can-resize? s x y)
|
|
((void) on-resize s x y)
|
|
((void) after-resize s x y ?)
|
|
(#t can-reorder? s s2 ?)
|
|
((void) on-reorder s s2 ?)
|
|
((void) after-reorder s s2 ?)
|
|
(#t can-select? s ?)
|
|
((void) on-select s ?)
|
|
((void) after-select s ?)
|
|
|
|
(#t can-interactive-move? e)
|
|
((void) on-interactive-move e)
|
|
((void) after-interactive-move e)
|
|
(#t can-interactive-resize? s)
|
|
((void) on-interactive-resize s)
|
|
((void) after-interactive-resize s))
|
|
(super-new)))
|
|
|
|
(define editor-snip%
|
|
(class wx:editor-snip% (init [editor #f]
|
|
[with-border? #t]
|
|
[left-margin 5]
|
|
[top-margin 5]
|
|
[right-margin 5]
|
|
[bottom-margin 5]
|
|
[left-inset 1]
|
|
[top-inset 1]
|
|
[right-inset 1]
|
|
[bottom-inset 1]
|
|
[min-width 'none]
|
|
[max-width 'none]
|
|
[min-height 'none]
|
|
[max-height 'none])
|
|
(super-make-object (or editor (make-object text%))
|
|
with-border?
|
|
left-margin
|
|
top-margin
|
|
right-margin
|
|
bottom-margin
|
|
left-inset
|
|
top-inset
|
|
right-inset
|
|
bottom-inset
|
|
min-width
|
|
max-width
|
|
min-height
|
|
max-height)))
|
|
|
|
(wx:set-extended-editor-snip%! editor-snip%)
|
|
(wx:set-extended-text%! text%)
|
|
(wx:set-extended-pasteboard%! pasteboard%)
|
|
|
|
;; ----------------------- Keymap ----------------------------------------
|
|
|
|
(define std-keymap (make-object wx:keymap%))
|
|
|
|
(let* ([k std-keymap]
|
|
[mouse-paste (lambda (edit event)
|
|
(when (send event button-down?)
|
|
(cond
|
|
[(is-a? edit wx:text%)
|
|
(let ([x-box (box (send event get-x))]
|
|
[y-box (box (send event get-y))]
|
|
[eol-box (box #f)])
|
|
(send edit global-to-local x-box y-box)
|
|
(let ([click-pos (send edit find-position
|
|
(unbox x-box)
|
|
(unbox y-box)
|
|
eol-box)])
|
|
(send edit set-position click-pos)))]
|
|
[else (void)])
|
|
(send edit paste-x-selection)))]
|
|
[mouse-popup-menu (lambda (edit event)
|
|
(when (send event button-up?)
|
|
(let ([a (send edit get-admin)])
|
|
(when a
|
|
(let ([m (make-object popup-menu%)])
|
|
(append-editor-operation-menu-items m)
|
|
;; Remove shortcut indicators (because they might not be correct)
|
|
(for-each
|
|
(lambda (i)
|
|
(when (is-a? i selectable-menu-item<%>)
|
|
(send i set-shortcut #f)))
|
|
(send m get-items))
|
|
(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 5) (+ y 5))))))))])
|
|
(wx:add-text-keymap-functions k)
|
|
(send k add-function "mouse-paste" mouse-paste)
|
|
(send k add-function "mouse-popup-menu" mouse-popup-menu)
|
|
(map
|
|
(lambda (key func) (send k map-function key func))
|
|
(append
|
|
(case (system-type)
|
|
[(windows) '(":c:c" ":c:x" ":c:v" ":c:k" ":c:z" ":c:a")]
|
|
[(macos macosx) '(":d:c" ":d:x" ":d:v" ":d:k" ":d:z" ":d:a")]
|
|
[(unix) '(":m:w" ":c:w" ":c:y" ":c:k" ":c:s:_" ":m:a")])
|
|
'(":middlebutton"))
|
|
'("copy-clipboard" "cut-clipboard" "paste-clipboard" "delete-to-end-of-line"
|
|
"undo" "select-all" "mouse-paste"))
|
|
(send k map-function ":rightbuttonseq" "mouse-popup-menu")
|
|
(when (eq? (system-type) 'unix)
|
|
(send k map-function ":c:a" "beginning-of-line")
|
|
(send k map-function ":c:e" "end-of-line")))
|
|
|
|
(define (check-installer who)
|
|
(lambda (p)
|
|
(unless (and (procedure? p)
|
|
(procedure-arity-includes? p 1))
|
|
(raise-argument-error who
|
|
"(procedure-arity-includes/c 1)"
|
|
p))
|
|
p))
|
|
|
|
(define current-text-keymap-initializer
|
|
(make-parameter (let ([default-text-keymap-initializer
|
|
(lambda (k)
|
|
(check-instance 'default-text-keymap-initializer wx:keymap% 'keymap% #f k)
|
|
;; Level of indirection to protect std-keymap:
|
|
(let ([naya (make-object wx:keymap%)])
|
|
(send naya chain-to-keymap std-keymap #f)
|
|
(send k chain-to-keymap naya #f)))])
|
|
default-text-keymap-initializer)
|
|
(check-installer 'default-text-keymap-initializer)))
|
|
|
|
(define (find-item-editor item)
|
|
(let ([o (let loop ([i item])
|
|
(let ([p (send i get-parent)])
|
|
(cond
|
|
[(not p) #f]
|
|
[(is-a? p popup-menu%)
|
|
(let ([p (send p get-popup-target)])
|
|
(if (is-a? p window<%>)
|
|
(let ([f (send p get-top-level-window)])
|
|
(and f (send f get-edit-target-object)))
|
|
p))]
|
|
[(is-a? p menu%) (loop p)]
|
|
[else (let ([f (send p get-frame)])
|
|
(and f (send f get-edit-target-object)))])))])
|
|
(and (is-a? o wx:editor<%>)
|
|
o)))
|
|
|
|
;; ------------------------- Menus ----------------------------------------
|
|
|
|
(define (append-editor-operation-menu-items m
|
|
[text-only? #t]
|
|
#:popup-position [popup-position #f])
|
|
(unless (or (not popup-position)
|
|
(and (list? popup-position)
|
|
(= 2 (length popup-position))
|
|
(is-a? (list-ref popup-position 0) text%)
|
|
(exact-nonnegative-integer? (list-ref popup-position 1))))
|
|
(raise-argument-error 'append-editor-operation-menu-items
|
|
(format "~s" '(or/c #f (list/c (is-a?/c text%) exact-nonnegative-integer?)))
|
|
popup-position))
|
|
(menu-parent-only 'append-editor-operation-menu-items m)
|
|
(let* ([mk (lambda (name key op [special-case? (λ () #f)] [special-go void])
|
|
(make-object (class menu-item%
|
|
(inherit enable)
|
|
(define/override (on-demand)
|
|
(let ([o (find-item-editor this)])
|
|
(enable (and o
|
|
(or (send o can-do-edit-operation? op)
|
|
(special-case?))))))
|
|
(super-make-object
|
|
name m
|
|
(lambda (i e)
|
|
(let* ([o (find-item-editor i)])
|
|
(and o
|
|
(if (special-case?)
|
|
(special-go)
|
|
(send o do-edit-operation op)))))
|
|
key))))]
|
|
[mk-sep (lambda () (make-object separator-menu-item% m))])
|
|
(define (special-case?)
|
|
(cond
|
|
[popup-position
|
|
(define snp (send (list-ref popup-position 0) find-snip
|
|
(list-ref popup-position 1)
|
|
'after-or-none))
|
|
(and snp (not (is-a? snp wx:string-snip%)))]
|
|
[else
|
|
#f]))
|
|
(define (copy-special-go)
|
|
(send (list-ref popup-position 0)
|
|
copy #f 0
|
|
(list-ref popup-position 1)
|
|
(+ (list-ref popup-position 1) 1)))
|
|
(define (cut-special-go)
|
|
(send (list-ref popup-position 0)
|
|
cut #f 0
|
|
(list-ref popup-position 1)
|
|
(+ (list-ref popup-position 1) 1)))
|
|
(mk "&Undo" #\z 'undo)
|
|
(mk "Redo" #f 'redo)
|
|
(mk-sep)
|
|
(mk "&Copy" #\c 'copy special-case? copy-special-go)
|
|
(mk "Cu&t" #\x 'cut special-case? cut-special-go)
|
|
(mk "&Paste" #\v 'paste)
|
|
(if (eq? (system-type) 'windows)
|
|
(mk "Delete" #f 'clear)
|
|
(mk "Clear" #f 'clear))
|
|
(mk "Select &All" #\a 'select-all)
|
|
(unless text-only?
|
|
(mk-sep)
|
|
(mk "Insert Text Box" #f 'insert-text-box)
|
|
(mk "Insert Pasteboard Box" #f 'insert-pasteboard-box)
|
|
(mk "Insert Image..." #f 'insert-image))
|
|
(void)))
|
|
|
|
(define (append-editor-font-menu-items m)
|
|
(menu-parent-only 'append-editor-font-menu-items m)
|
|
(let ([mk (lambda (name m cb)
|
|
(make-object menu-item% name m
|
|
(lambda (i e)
|
|
(let* ([o (find-item-editor i)])
|
|
(and o (cb o))))))]
|
|
[mk-sep (lambda (m) (make-object separator-menu-item% m))]
|
|
[mk-menu (lambda (name) (make-object menu% name m))])
|
|
(let ([family (mk-menu "Font")]
|
|
[size (mk-menu "Size")]
|
|
[style (mk-menu "Style")]
|
|
[weight (mk-menu "Weight")]
|
|
[underline (mk-menu "Underline")]
|
|
[alignment (mk-menu "Alignment")]
|
|
[color (mk-menu "Color")]
|
|
[background (mk-menu "Background")])
|
|
|
|
; Font menu
|
|
(for-each (lambda (l f)
|
|
(mk l family
|
|
(lambda (e)
|
|
(send e change-style (make-object wx:style-delta% 'change-family f)))))
|
|
'("Standard" "Decorative" "Roman" "Script" "Swiss" "Fixed" "Symbol")
|
|
'(default decorative roman script swiss modern symbol))
|
|
(mk-sep family)
|
|
(mk "Choose..." family (lambda (e) (let ([f ((get-get-font-from-user))])
|
|
(when f
|
|
(send e change-style (font->delta f))))))
|
|
|
|
; Size menu
|
|
(let ([bigger (make-object menu% "Bigger" size)]
|
|
[smaller (make-object menu% "Smaller" size)]
|
|
[add-change-size
|
|
(lambda (m ls dss xss)
|
|
(for-each (lambda (l ds xs)
|
|
(mk l m (lambda (e)
|
|
(let ([d (make-object wx:style-delta%)])
|
|
(send d set-size-add ds)
|
|
(send d set-size-mult xs)
|
|
(send e change-style d)))))
|
|
ls dss xss))])
|
|
(add-change-size bigger
|
|
'("+1" "+2" "+4" "+8" "+16" "+32")
|
|
'(1 2 4 8 16 32)
|
|
'(1 1 1 1 1 1))
|
|
(mk-sep bigger)
|
|
(add-change-size bigger
|
|
'("x2" "x3" "x4" "x5")
|
|
'(0 0 0 0)
|
|
'(2 3 4 5))
|
|
|
|
(add-change-size smaller
|
|
'("-1" "-2" "-4" "-8" "-16" "-32")
|
|
'(1 -2 -4 -8 -16 -32)
|
|
'(1 1 1 1 1 1))
|
|
(mk-sep smaller)
|
|
(add-change-size smaller
|
|
'("/2" "/3" "/5" "/5")
|
|
'(0 0 0 0)
|
|
'(#i1/2 #i1/3 #i1/4 #i1/5))
|
|
|
|
(for-each (lambda (s)
|
|
(mk (number->string s) size (lambda (e)
|
|
(let ([d (make-object wx:style-delta%)])
|
|
(send d set-size-add s)
|
|
(send d set-size-mult 0)
|
|
(send e change-style d)))))
|
|
'(9 10 12 14 16 24 32 48)))
|
|
|
|
|
|
(let ([mk-cg (lambda (cmd arg)
|
|
(lambda (e) (send e change-style (make-object wx:style-delta% cmd arg))))])
|
|
|
|
; Style
|
|
(for-each (lambda (name s)
|
|
(mk name style (mk-cg 'change-style s)))
|
|
'("Normal" "Italic" "Slant")
|
|
'(normal italic slant))
|
|
|
|
; Weight
|
|
(for-each (lambda (name s)
|
|
(mk name weight (mk-cg 'change-weight s)))
|
|
'("Normal" "Bold" "Light")
|
|
'(normal bold light))
|
|
|
|
; Underline
|
|
(mk "No Underline" underline (mk-cg 'change-underline #f))
|
|
(mk "Underline" underline (mk-cg 'change-underline #t))
|
|
(mk "Toggle" underline (lambda (e) (send e change-style (make-object wx:style-delta% 'change-toggle-underline))))
|
|
|
|
; Alignment
|
|
(for-each (lambda (name s)
|
|
(mk name alignment (mk-cg 'change-alignment s)))
|
|
'("Top" "Center" "Bottom")
|
|
'(top center bottom))
|
|
|
|
(let ([colors '("Black" "White" "Red" "Orange" "Yellow" "Green" "Blue" "Purple" "Cyan" "Magenta" "Grey")])
|
|
|
|
; Colors
|
|
(for-each (lambda (c)
|
|
(mk c color (lambda (e) (let ([d (make-object wx:style-delta%)])
|
|
(send d set-delta-foreground c)
|
|
(send e change-style d)))))
|
|
colors)
|
|
|
|
; Background
|
|
(mk "Transparent" background (lambda (e) (let ([d (make-object wx:style-delta%)])
|
|
(send d set-transparent-text-backing-on #t)
|
|
(send e change-style d))))
|
|
(for-each (lambda (c)
|
|
(mk c background (lambda (e) (let ([d (make-object wx:style-delta%)])
|
|
(send d set-delta-background c)
|
|
(send e change-style d)))))
|
|
colors))))))
|