.

original commit: 1ab7bef9a91b9694896003bfdbd620b43f8f069b
2004-12-27 19:40:53 +00:00 · 2004-12-27 19:40:53 +00:00 · 57c7016b58
commit 57c7016b58
parent 66f2bd42bb
1 changed files with 51 additions and 0 deletions
--- a/collects/framework/keybinding-lang.ss
+++ b/collects/framework/keybinding-lang.ss
@ -0,0 +1,51 @@
+(module keybinding-lang mzscheme
+  (require (lib "mred.ss" "mred")
+           (lib "string-constant.ss" "string-constants")
+           (lib "framework.ss" "framework")
+           (lib "class.ss"))
+  
+  (provide (rename kl-module-begin #%module-begin)
+           (all-from-except mzscheme #%module-begin)
+           (all-from (lib "framework.ss" "framework"))
+           (all-from (lib "mred.ss" "mred"))
+           (all-from (lib "class.ss")))
+  
+  (define-syntax (kl-module-begin stx)
+    (syntax-case stx ()
+      [(mb a ...) 
+       (with-syntax ([#%keymap (datum->syntax-object (syntax mb) '#%keymap)]
+                     [#%keybinding (datum->syntax-object (syntax mb) '#%keybinding)]
+                     [keybinding (datum->syntax-object (syntax mb) 'keybinding)])
+         (syntax (#%plain-module-begin 
+                  (define #%keymap (make-object keymap:aug-keymap%))
+                  (provide #%keymap)
+                  (define (#%keybinding key proc src line col pos)
+                    (unless (string? key)
+                      (error 'keybinding "expected string as first argument, got ~e (other arg ~e)" key proc))
+                    (unless (and (procedure? proc)
+                                 (procedure-arity-includes? proc 2))
+                      (error 'keybinding "expected procedure of two arguments as second argument, got ~e (other arg ~e)"
+                             proc
+                             key))
+                    (let ([name (if (and line col)
+                                    (format "~a:~a.~a" src line col)
+                                    (format "~a:~a" src pos))])
+                      (send #%keymap add-function name 
+                            (lambda (x y)
+                              (with-handlers ([exn:fail? 
+                                               (lambda (x)
+                                                 (message-box (string-constant drscheme)
+                                                              (format (string-constant user-defined-keybinding-error) 
+                                                                      name
+                                                                      (exn-message x))))])
+                                (proc x y))))
+                      (send #%keymap map-function key name)))
+                  (define-syntax (keybinding stx)
+                    (syntax-case stx ()
+                      [(_ key val)
+                       (with-syntax ([src (syntax-source stx)]
+                                     [line (syntax-line stx)]
+                                     [col (syntax-column stx)]
+                                     [pos (syntax-position stx)])
+                         (syntax (#%keybinding key val 'src 'line 'col 'pos)))]))
+                  a ...)))])))