178 lines
6.1 KiB
Scheme
178 lines
6.1 KiB
Scheme
|
|
(module keymap mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "unit.ss")
|
|
(lib "mred.ss" "mred")
|
|
"interfaces.ss"
|
|
"partition.ss")
|
|
(provide keymap@
|
|
context-menu@)
|
|
|
|
(define context-menu@
|
|
(unit
|
|
(import)
|
|
(export context-menu^)
|
|
|
|
(define context-menu%
|
|
(class popup-menu%
|
|
(init-field keymap)
|
|
(init-field controller)
|
|
(super-new)
|
|
|
|
(field [copy-menu #f]
|
|
[copy-syntax-menu #f]
|
|
[clear-menu #f]
|
|
[props-menu #f])
|
|
|
|
(define/public (add-edit-items)
|
|
(set! copy-menu
|
|
(new menu-item% (label "Copy") (parent this)
|
|
(callback (lambda (i e)
|
|
(send keymap call-function "copy-text" i e)))))
|
|
(set! copy-syntax-menu
|
|
(new menu-item% (label "Copy syntax") (parent this)
|
|
(callback (lambda (i e)
|
|
(send keymap call-function "copy-syntax" i e)))))
|
|
(void))
|
|
|
|
(define/public (after-edit-items)
|
|
(void))
|
|
|
|
(define/public (add-selection-items)
|
|
(set! clear-menu
|
|
(new menu-item%
|
|
(label "Clear selection")
|
|
(parent this)
|
|
(callback
|
|
(lambda (i e)
|
|
(send keymap call-function "clear-syntax-selection" i e)))))
|
|
(set! props-menu
|
|
(new menu-item%
|
|
(label "Show syntax properties")
|
|
(parent this)
|
|
(callback
|
|
(lambda (i e)
|
|
(send keymap call-function "show-syntax-properties" i e)))))
|
|
(void))
|
|
|
|
(define/public (after-selection-items)
|
|
(void))
|
|
|
|
(define/public (add-partition-items)
|
|
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
|
(for-each
|
|
(lambda (name func)
|
|
(let ([this-choice
|
|
(new checkable-menu-item%
|
|
(label name)
|
|
(parent secondary)
|
|
(callback
|
|
(lambda (i e)
|
|
(send controller on-update-identifier=? name func))))])
|
|
(send controller add-identifier=?-listener
|
|
(lambda (new-name new-id=?)
|
|
(send this-choice check (eq? name new-name))))))
|
|
(map car (identifier=-choices))
|
|
(map cdr (identifier=-choices))))
|
|
(void))
|
|
|
|
(define/public (after-partition-items)
|
|
(void))
|
|
|
|
(define/public (add-separator)
|
|
(new separator-menu-item% (parent this)))
|
|
|
|
(define/override (on-demand)
|
|
(define stx (send controller get-selected-syntax))
|
|
(send copy-menu enable (and stx #t))
|
|
(send copy-syntax-menu enable (and stx #t))
|
|
(send clear-menu enable (and stx #t))
|
|
(super on-demand))
|
|
|
|
;; Initialization
|
|
(add-edit-items)
|
|
(after-edit-items)
|
|
|
|
(add-separator)
|
|
(add-selection-items)
|
|
(after-selection-items)
|
|
|
|
(add-separator)
|
|
(add-partition-items)
|
|
(after-partition-items)
|
|
|
|
))))
|
|
|
|
(define keymap@
|
|
(unit
|
|
(import context-menu^ snip^)
|
|
(export keymap^)
|
|
|
|
(define syntax-keymap%
|
|
(class keymap%
|
|
(init editor)
|
|
(init-field controller)
|
|
|
|
(inherit add-function
|
|
map-function
|
|
chain-to-keymap)
|
|
(super-new)
|
|
|
|
(define context-menu (make-context-menu))
|
|
|
|
(define/public (make-context-menu)
|
|
(new context-menu% (controller controller) (keymap this)))
|
|
|
|
;; Key mappings
|
|
|
|
(map-function "rightbutton" "popup-context-window")
|
|
|
|
;; Functionality
|
|
|
|
(add-function "popup-context-window"
|
|
(lambda (editor event)
|
|
(do-popup-context-window editor event)))
|
|
|
|
(add-function "copy-text"
|
|
(lambda (_ event)
|
|
(define stx (send controller get-selected-syntax))
|
|
(send the-clipboard set-clipboard-string
|
|
(if stx
|
|
(format "~s" (syntax-object->datum stx))
|
|
"")
|
|
(send event get-time-stamp))))
|
|
|
|
(add-function "copy-syntax"
|
|
(lambda (_ event)
|
|
(define stx (send controller get-selected-syntax))
|
|
(define t (new text%))
|
|
(send t insert
|
|
(new syntax-snip%
|
|
(syntax stx)))
|
|
(send t select-all)
|
|
(send t copy)))
|
|
|
|
(add-function "clear-syntax-selection"
|
|
(lambda (i e)
|
|
(send controller select-syntax #f)))
|
|
|
|
(add-function "show-syntax-properties"
|
|
(lambda (i e)
|
|
(error 'show-syntax-properties "not provided by this keymap")))
|
|
|
|
;; Attach to editor
|
|
|
|
(chain-to-keymap (send editor get-keymap) #t)
|
|
(send editor set-keymap this)
|
|
|
|
(define/public (get-controller) controller)
|
|
|
|
(define/private (do-popup-context-window editor event)
|
|
(define-values (x y)
|
|
(send editor dc-location-to-editor-location
|
|
(send event get-x)
|
|
(send event get-y)))
|
|
(define admin (send editor get-admin))
|
|
(send admin popup-menu context-menu x y))))))
|
|
)
|