1  #lang scheme
 2  (require mred
 3           string-constants
 4           framework
 5           scheme/class)
 6  
 7  (provide (rename-out (kl-module-begin #%module-begin))
 8           (except-out (all-from-out scheme) #%module-begin)
 9           (all-from-out framework
10                         mred
11                         scheme/class))
12  
13  (define-syntax (kl-module-begin stx)
14    (syntax-case stx ()
15      [(mb a ...) 
16       (with-syntax ([#%keymap (datum->syntax (syntax mb) '#%keymap)]
17                     [#%keybinding (datum->syntax (syntax mb) '#%keybinding)]
18                     [keybinding (datum->syntax (syntax mb) 'keybinding)])
19         (syntax (#%plain-module-begin 
20                  (define #%keymap (make-object keymap:aug-keymap%))
21                  (provide #%keymap)
22                  (define name-counter (make-hash))
23                  (define (unique-name raw-name)
24                    (let ([last-number (hash-ref name-counter raw-name #f)])
25                      (cond
26                        [last-number
27                         (hash-set! name-counter raw-name (+ last-number 1))
28                         (format "~a:~a" raw-name last-number)]
29                        [else
30                         (hash-set! name-counter raw-name 2)
31                         raw-name])))
32                  (define (#%keybinding key proc src line col pos)
33                    (unless (string? key)
34                      (error 'keybinding "expected string as first argument, got ~e (other arg ~e)" key proc))
35                    (unless (and (procedure? proc)
36                                 (procedure-arity-includes? proc 2))
37                      (error 'keybinding "expected procedure of two arguments as second argument, got ~e (other arg ~e)"
38                             proc
39                             key))
40                    (let ([name 
41                           (unique-name
42                            (cond
43                              [(symbol? (object-name proc))
44                               (format "~a" (object-name proc))]
45                              [(and line col)
46                               (format "~a:~a.~a" src line col)]
47                              [else
48                               (format "~a:~a" src pos)]))])
49                      (send #%keymap add-function name 
50                            (λ (x y)
51                              (let ([end-edit-sequence
52                                     (λ ()
53                                       (when (is-a? x editor<%>)
54                                         (let loop ()
55                                           (when (send x in-edit-sequence?)
56                                             (send x end-edit-sequence)
57                                             (loop)))))])
58                                (with-handlers ([exn:fail? 
59                                                 (λ (x)
60                                                   (end-edit-sequence)
61                                                   (message-box (string-constant drscheme)
62                                                                (format (string-constant user-defined-keybinding-error) 
63                                                                        name
64                                                                        (exn-message x))))])
65                                  (proc x y)
66                                  (when (is-a? x editor<%>)
67                                    (when (send x in-edit-sequence?)
68                                      (end-edit-sequence)
69                                      (message-box (string-constant drscheme)
70                                                   (format (string-constant user-defined-keybinding-error) 
71                                                           name
72                                                           "Editor left in edit-sequence"))))))))
73                      (send #%keymap map-function key name)))
74                  (define-syntax (keybinding stx)
75                    (syntax-case stx ()
76                      [(_ key val)
77                       (with-syntax ([src (syntax-source stx)]
78                                     [line (syntax-line stx)]
79                                     [col (syntax-column stx)]
80                                     [pos (syntax-position stx)])
81                         (syntax (#%keybinding key val 'src 'line 'col 'pos)))]))
82                  a ...)))]))