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" "Gray")])
|
|
|
|
; 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))))))
|