
(module keymap mzscheme
  (require (lib "string-constant.ss" "string-constants")
           (lib "unitsig.ss")
	   (lib "class.ss")
	   (lib "list.ss")
	   (lib "mred-sig.ss" "mred")
           (lib "match.ss")
           "sig.ss")
  
  (provide keymap@)
  
  (define keymap@ 
    (unit/sig framework:keymap^
      (import mred^
	      [preferences : framework:preferences^]
	      [finder : framework:finder^]
	      [handler : framework:handler^]
	      [frame : framework:frame^]
              [editor : framework:editor^])
      
      (rename [-get-file get-file])

      (define user-keybindings-files (make-hash-table 'equal))
      
      (define (add-user-keybindings-file path)
        (hash-table-get 
         user-keybindings-files
         path
         (λ ()
           (let ([sexp (and (file-exists? path)
                            (call-with-input-file path read))])
             (match sexp
               [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) 
                 (let ([km (dynamic-require path '#%keymap)])
                   (hash-table-put! user-keybindings-files path km)
                   (send global chain-to-keymap km #t))]
               [else (error 'add-user-keybindings-file 
                            (string-constant user-defined-keybinding-malformed-file)
                            (path->string path))])))))
      
      (define (remove-user-keybindings-file path)
        (let/ec k
          (let ([km (hash-table-get user-keybindings-files path (λ () (k (void))))])
            (send global remove-chained-keymap km)
            (hash-table-remove! user-keybindings-files path))))
      
      (define (remove-chained-keymap ed keymap-to-remove)
        (let ([ed-keymap (send ed get-keymap)])
          (when (eq? keymap-to-remove ed-keymap)
            (error 'keymap:remove-keymap "cannot remove initial keymap from editor"))
          (let p-loop ([parent-keymap ed-keymap])
            (unless (is-a? parent-keymap aug-keymap<%>)
              (error 'keymap:remove-keymap
                     "found a keymap that is not a keymap:aug-keymap<%> ~e" 
                     parent-keymap))
            (let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)])
              (cond
                [(null? child-keymaps) null]
                [else
                 (let ([child-keymap (car child-keymaps)])
                   (cond
                     [(eq? child-keymap keymap-to-remove)
                      (send parent-keymap remove-chained-keymap child-keymap)
                      (c-loop (cdr child-keymaps))]
                     [else 
                      (p-loop child-keymap)
                      (c-loop (cdr child-keymaps))]))])))))
      
      (define (set-chained-keymaps parent-keymap children-keymaps)
        (for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap))
                  (send parent-keymap get-chained-keymaps))
        (for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
                  children-keymaps))
        
      (define aug-keymap<%> (interface ((class->interface keymap%))
			      get-chained-keymaps
			      get-map-function-table
			      get-map-function-table/ht))
      
      (define aug-keymap-mixin
	(mixin ((class->interface keymap%)) (aug-keymap<%>)
          (define chained-keymaps null)
	  (define/public (get-chained-keymaps) chained-keymaps)
	  
	  (define/override (chain-to-keymap keymap prefix?)
            (super chain-to-keymap keymap prefix?)
            (set! chained-keymaps
                  (if prefix?
                      (cons keymap chained-keymaps)
                      (append chained-keymaps (list keymap)))))
	  
          (define/override (remove-chained-keymap keymap)
            (super remove-chained-keymap keymap)
            (set! chained-keymaps (remq keymap chained-keymaps)))
          
	  (define function-table (make-hash-table))
          (define/public (get-function-table) function-table)
	  (define/override (map-function keyname fname)
            (super map-function (canonicalize-keybinding-string keyname) fname)
            (hash-table-put! function-table (string->symbol keyname) fname))
	  
	  (define/public (get-map-function-table)
            (get-map-function-table/ht (make-hash-table)))
          
          (define/public (get-map-function-table/ht table)
            (hash-table-for-each
             function-table
             (λ (keyname fname)
               (unless (hash-table-get table keyname (λ () #f))
                 (hash-table-put! table keyname fname))))
            (for-each
             (λ (chained-keymap)
               (when (is-a? chained-keymap aug-keymap<%>)
                 (send chained-keymap get-map-function-table/ht table)))
             chained-keymaps)
            table)
          
          (super-new)))
      
      (define aug-keymap% (aug-keymap-mixin keymap%))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;                                                     ;;;;;;;;
      ;;;;;;;           canonicalize-keybinding-string            ;;;;;;;;
      ;;;;;;;                                                     ;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
      ;; canonicalize-keybinding-string : string -> string
      ;; The result can be used with string=? to determine
      ;; if two key bindings refer to the same key.
      ;; Assumes a well-formed keystring.
      (define (canonicalize-keybinding-string str)
	(let* ([chars (map char-downcase (string->list str))]
	       [separated-keys
		(map
		 canonicalize-single-keybinding-string
		 (split-out #\; chars))])
	  (join-strings ";" separated-keys)))
      
      ;; join-strings : string (listof string) -> string
      ;; concatenates strs with sep between each of them
      (define (join-strings sep strs)
	(if (null? strs)
	    ""
	    (apply
	     string-append
	     (cons
	      (car strs)
	      (let loop ([sepd-strs (cdr strs)])
		(cond
                  [(null? sepd-strs) null]
                  [else (list*
                         sep
                         (car sepd-strs)
                         (loop (cdr sepd-strs)))]))))))
      
      ;; canonicalize-single-keybinding-string : (listof char) -> string
      (define (canonicalize-single-keybinding-string chars)
	(let* ([neg? (char=? (car chars) #\:)]
	       [mods/key (split-out #\: (if neg? (cdr chars) chars))]
	       [mods
		(let loop ([mods mods/key])
		  (cond
                    [(null? mods) null]
                    [(null? (cdr mods)) null]
                    [else (cons (car mods) (loop (cdr mods)))]))]
	       [key (apply string (car (last-pair mods/key)))]
               [canon-key
                (cond
                  [(string=? key "enter") "return"]
                  [(string=? key "del") "delete"]
                  [(string=? key "ins") "insert"]
                  [else key])]
	       [shift (if neg? #f 'd/c)]
	       [control (if neg? #f 'd/c)]
	       [alt (if neg? #f 'd/c)]
	       [meta (if neg? #f 'd/c)]
	       [command (if neg? #f 'd/c)]
               
	       [do-key
		(λ (char val)
		  (cond
                    [(eq? val #t) (string char)]
                    [(eq? val #f) (string #\~ char)]
                    [(eq? val 'd/c) #f]))])
          
	  (for-each (λ (mod)
		      (let ([val (not (char=? (car mod) #\~))])
			(case (if (char=? (car mod) #\~)
				  (cadr mod)
				  (car mod))
			  [(#\s) (set! shift val)]
			  [(#\c) (set! control val)]
			  [(#\a) (set! alt val)]
			  [(#\d) (set! command val)]
			  [(#\m) (set! meta val)])))
		    mods)
          
	  (join-strings ":"
			(filter
			 (λ (x) x)
			 (list
			  (do-key #\a alt)
			  (do-key #\c control)
			  (do-key #\d command)
			  (do-key #\m meta)
			  (do-key #\s shift)
			  canon-key)))))
      
      ;; split-out : char (listof char) -> (listof (listof char))
      ;; splits a list of characters at its first argument
      ;; if the last character is the same as the first character,
      ;; it is not split into an empty list, but returned.
      (define (split-out split-char chars)
	(let loop ([chars chars]
		   [this-split null]
		   [all-split null])
	  (cond
            [(null? chars)
             (reverse (cons (reverse this-split) all-split))]
            [else (let ([char (car chars)])
                    (cond
                      [(char=? split-char char)
                       (if (null? (cdr chars))
                           (loop null
                                 (cons char this-split)
                                 all-split)
                           (loop (cdr chars)
                                 null
                                 (cons (reverse this-split) all-split)))]
                      [else
                       (loop (cdr chars)
                             (cons char this-split)
                             all-split)]))])))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;                                                     ;;;;;;;;
      ;;;;;;;         end canonicalize-keybinding-string          ;;;;;;;;
      ;;;;;;;                                                     ;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
      (define (make-meta-prefix-list key)
	(let ([defaults
		(list (string-append "m:" key)
		      (string-append "ESC;" key))])
	  (if (eq? (system-type) 'macosx)
	      (cons (string-append "a:" key)
		    defaults)
	      defaults)))
      
      (define send-map-function-meta
	(λ (keymap key func)
	  (for-each (λ (key) (send keymap map-function key func))
		    (make-meta-prefix-list key))))
      
      (define add-to-right-button-menu (make-parameter void))
      (define add-to-right-button-menu/before (make-parameter void))
      
      (define setup-global
        ; Define some useful keyboard functions
	(let* ([ring-bell
		(λ (edit event)
		  (bell))]
	       
	       [mouse-popup-menu 
		(λ (edit event)
		  (when (send event button-down?)
		    (let ([a (send edit get-admin)])
		      (when a
			(let ([m (make-object popup-menu%)])
                          
                          ((add-to-right-button-menu/before) m edit event)
                          
			  (append-editor-operation-menu-items m)
			  (for-each
			   (λ (i)
			     (when (is-a? i selectable-menu-item<%>)
			       (send i set-shortcut #f)))
			   (send m get-items))
                          
			  ((add-to-right-button-menu) m edit event)
                          
			  (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 1) (+ y 1))))))))]
               
	       [toggle-anchor
		(λ (edit event)
		  (send edit set-anchor
			(not (send edit get-anchor))))]
	       [center-view-on-line
		(λ (edit event)
		  (let ([new-mid-line (send edit position-line
					    (send edit get-start-position))]
			[bt (box 0)]
			[bb (box 0)])
		    (send edit get-visible-line-range bt bb #f)
		    (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
			   [last-pos (send edit position-line (send edit last-position))]
			   [top-pos (send edit line-start-position 
					  (max (min (- new-mid-line half) last-pos) 0))]
			   [bottom-pos (send edit line-start-position 
					     (max 0
						  (min (+ new-mid-line half)
						       last-pos)))])
		      (send edit scroll-to-position 
			    top-pos
			    #f
			    bottom-pos)))
		  #t)]

	       [make-insert-brace-pair
		(λ (open-brace close-brace)
		  (λ (edit event)
		    (send edit begin-edit-sequence)
                    (let ([selection-start (send edit get-start-position)])
                      (send edit set-position (send edit get-end-position))
                      (send edit insert close-brace)
                      (send edit set-position selection-start)
                      (send edit insert open-brace))
		    (send edit end-edit-sequence)))]
               
               [insert-lambda-template
                (λ (edit event)
                  (send edit begin-edit-sequence)
                  (let ([selection-start (send edit get-start-position)])
                    (send edit set-position (send edit get-end-position))
                    (send edit insert ")")
                    (send edit set-position selection-start)
                    (send edit insert ") ")
                    (send edit set-position selection-start)
                    (send edit insert "(λ ("))
                  (send edit end-edit-sequence))]

	       [collapse-variable-space
                ;; As per emacs: collapse tabs & spaces around the point,
                ;; perhaps leaving a single space.
                ;; drscheme bonus: if at end-of-line, collapse into the next line.
		(λ (leave-one? edit event)
		  (letrec ([last-pos  (send edit last-position)]
		           [sel-start (send edit get-start-position)]
			   [sel-end   (send edit get-end-position)]
                           [collapsible? (λ (c) (and (char-whitespace? c)
                                                          (not (char=? #\newline c))))]
			   [find-noncollapsible
                            ; Return index of next non-collapsible char,
                            ; starting at pos in direction dir.
                            ; NB returns -1 or last-pos, if examining
                            ; initial/final whitespace
                            ; (or, when initial pos is outside of [0,last-pos).)
			    (λ (pos dir)
			      (let loop ([pos pos])
                                (cond [(<  pos 0) -1]
                                      [(>= pos last-pos) last-pos]
                                      [(collapsible? (send edit get-character pos))
                                       (loop (+ pos dir))]
                                      [else pos])))])
                    (when (= sel-start sel-end) ; Only when no selection:
                      (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))]
                             [end-heeding-eol (find-noncollapsible sel-start +1)]
                             ; This is the end of the range, were we to always heed newlines.
                             
                             ; Special case: if we're sitting at EOL,
                             ; and we're not affecting much else,
                             ; then delete that EOL and collapse spaces
                             ; at the start of next line, too:
                             [end (if (and (<= (- end-heeding-eol start)
                                               (if leave-one? 1 0))
                                           (char=? #\newline (send edit get-character end-heeding-eol))
                                           ; If you wish to avoid deleting an newline at EOF, do so here.
                                           )
                                      (find-noncollapsible (add1 end-heeding-eol) +1)
                                      end-heeding-eol)]
                             [making-no-difference?
                              ; Don't introduce edits into undo-chain, if no effect.
                              (if leave-one?
                                  (and (= (- end start) 1)
                                       (char=? #\space (send edit get-character start)))
                                  (= (- end start) 0))])
                        (unless making-no-difference?
                          (send edit begin-edit-sequence)
                          (send edit set-position end) ; Even after delete, caret will be at "end".
                          (send edit delete start end)
                          (when leave-one? (send edit insert #\space start))
                          (send edit end-edit-sequence))))))]
	       
	       [collapse-space
		(λ (edit event)
		  (collapse-variable-space #t edit event))]
	       
	       [remove-space
		(λ (edit event)
		  (collapse-variable-space #f edit event))]
	       
	       [collapse-newline
		(λ (edit event)
		  (letrec ([find-nonwhite
			    (λ (pos d offset)
			      (let/ec escape
				(let ([max (if (> offset 0)
					       (send edit last-position)
					       0)])
				  (let loop ([pos pos])
				    (if (= pos max)
					(escape pos)
					(let ([c (send edit get-character (+ pos offset))])
					  (cond
                                            [(char=? #\newline c)
                                             (loop (+ pos d))
                                             (escape pos)]
                                            [(char-whitespace? c) 
                                             (loop (+ pos d))]
                                            [else pos])))))))])
		    (let ([sel-start (send edit get-start-position)]
			  [sel-end (send edit get-end-position)])
		      (when (= sel-start sel-end)
			(let* ([pos-line (send edit position-line sel-start #f)]
			       [pos-line-start (send edit line-start-position pos-line)]
			       [pos-line-end (send edit line-end-position pos-line)]
			       
			       [whiteline?
				(let loop ([pos pos-line-start])
				  (if (>= pos pos-line-end)
				      #t
				      (and (char-whitespace? (send edit get-character pos))
					   (loop (add1 pos)))))]
			       
			       [start (find-nonwhite pos-line-start -1 -1)]
			       [end (find-nonwhite pos-line-end 1 0)]
			       
			       [start-line 
				(send edit position-line start #f)]
			       [start-line-start
				(send edit line-start-position start-line)]
			       [end-line
				(send edit position-line end #f)]
			       [end-line-start
				(send edit line-start-position (add1 end-line))])
			  (cond
                            [(and whiteline?
                                  (= start-line pos-line)
                                  (= end-line pos-line))
                             ; Special case: just delete this line
                             (send edit delete pos-line-start (add1 pos-line-end))]
                            [(and whiteline? (< start-line pos-line))
                             ; Can delete before & after
                             (send* edit 
                               (begin-edit-sequence)
                               (delete (add1 pos-line-end) end-line-start)
                               (delete start-line-start pos-line-start)
                               (end-edit-sequence))]
                            [else
                             ; Only delete after
                             (send edit delete (add1 pos-line-end) 
                                   end-line-start)]))))))]
	       
	       [open-line
		(λ (edit event)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)])
		    (if (= sel-start sel-end)
			(send* edit 
                          (insert #\newline)
                          (set-position sel-start)))))]
	       
	       [transpose-chars
		(λ (edit event)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)])
		    (when (and (= sel-start sel-end)
			       (not (= sel-start 0)))
		      
		      (let ([sel-start
			     (if (= sel-start
				    (send edit line-end-position
					  (send edit position-line sel-start)))
				 (sub1 sel-start)
				 sel-start)])
			(let ([s (send edit get-text
				       sel-start (add1 sel-start))])
			  (send* edit
                            (begin-edit-sequence)
                            (delete sel-start (add1 sel-start))
                            (insert s (- sel-start 1))
                            (set-position (add1 sel-start))
                            (end-edit-sequence)))))))]
	       
	       [transpose-words
		(λ (edit event)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)])
		    (when (= sel-start sel-end)
		      (let ([word-1-start (box sel-start)])
			(send edit find-wordbreak word-1-start #f 'caret)
			(let ([word-1-end (box (unbox word-1-start))])
			  (send edit find-wordbreak #f word-1-end 'caret)
			  (let ([word-2-end (box (unbox word-1-end))])
			    (send edit find-wordbreak #f word-2-end 'caret)
			    (let ([word-2-start (box (unbox word-2-end))])
			      (send edit find-wordbreak word-2-start #f 'caret)
			      (let ([text-1 (send edit get-text
						  (unbox word-1-start)
						  (unbox word-1-end))]
				    [text-2 (send edit get-text
						  (unbox word-2-start)
						  (unbox word-2-end))])
				(send* edit
                                  (begin-edit-sequence)
                                  (insert text-1 
                                          (unbox word-2-start)
                                          (unbox word-2-end))
                                  (insert text-2 
                                          (unbox word-1-start)
                                          (unbox word-1-end))
                                  (set-position (unbox word-2-end))
                                  (end-edit-sequence))))))))))]
	       
	       [capitalize-it
		(λ (edit char-case1 char-case2)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)]
			[real-end (send edit last-position)])
		    (when (= sel-start sel-end)
		      (let ([word-end (let ([b (box sel-start)])
					(send edit find-wordbreak #f b 'caret)
					(min real-end (unbox b)))])
			(send edit begin-edit-sequence)
			(let loop ([pos sel-start]
				   [char-case char-case1])
			  (when (< pos word-end)
			    (let ([c (send edit get-character pos)])
			      (cond
                                [(char-alphabetic? c)
                                 (send edit insert 
                                       (list->string
                                        (list (char-case c)))
                                       pos (add1 pos))
                                 (loop (add1 pos) char-case2)]
                                [else 
                                 (loop (add1 pos) char-case)]))))
			(send* edit 
                          (end-edit-sequence)
                          (set-position word-end))))))]
	       
	       [capitalize-word
		(λ (edit event)
		  (capitalize-it edit char-upcase char-downcase))]
	       [upcase-word
		(λ (edit event)
		  (capitalize-it edit char-upcase char-upcase))]
	       [downcase-word
		(λ (edit event)
		  (capitalize-it edit char-downcase char-downcase))]
	       
	       [kill-word
		(λ (edit event)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)])
		    (let ([end-box (box sel-end)])
		      (send edit find-wordbreak #f end-box 'caret)
		      (send edit kill 0 sel-start (unbox end-box)))))]
	       
	       [backward-kill-word
		(λ (edit event)
		  (let ([sel-start (send edit get-start-position)]
			[sel-end (send edit get-end-position)])
		    (let ([start-box (box sel-start)])
		      (send edit find-wordbreak start-box #f 'caret)
		      (send edit kill 0 (unbox start-box) sel-end))))]
	       
	       [region-click
		(λ (edit event f)
		  (when (and (send event button-down?)
			     (is-a? edit 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)]
			    [start-pos (send edit get-start-position)]
			    [end-pos (send edit get-end-position)])
			(let ([eol (unbox eol-box)])
			  (if (< start-pos click-pos)
			      (f click-pos eol start-pos click-pos)
			      (f click-pos eol click-pos end-pos)))))))]
	       [copy-click-region
		(λ (edit event)
		  (region-click edit event
				(λ (click eol start end)
				  (send edit flash-on start end)
				  (send edit copy #f 0 start end))))]
	       [cut-click-region
		(λ (edit event)
		  (region-click edit event
				(λ (click eol start end)
				  (send edit cut #f 0 start end))))]
	       [paste-click-region
		(λ (edit event)
		  (region-click edit event
				(λ (click eol start end)
				  (send edit set-position click)
				  (send edit paste-x-selection 0 click))))]
	       
	       [mouse-copy-clipboard
		(λ (edit event)
		  (send edit copy #f (send event get-time-stamp)))]
	       
	       [mouse-paste-clipboard
		(λ (edit event)
		  (send edit paste (send event get-time-stamp)))]
	       
	       [mouse-cut-clipboard
		(λ (edit event)
		  (send edit cut #f (send event get-time-stamp)))]
	       
	       [select-click-word
		(λ (edit event)
		  (region-click edit event
				(λ (click eol start end)
				  (let ([start-box (box click)]
					[end-box (box click)])
				    (send edit find-wordbreak 
					  start-box
					  end-box
					  'selection)
				    (send edit set-position
					  (unbox start-box)
					  (unbox end-box))))))]
	       [select-click-line
		(λ (edit event)
		  (region-click edit event
				(λ (click eol start end)
				  (let* ([line (send edit position-line 
						     click eol)]
					 [start (send edit line-start-position
						      line #f)]
					 [end (send edit line-end-position
						    line #f)])
				    (send edit set-position start end)))))]
	       
	       [goto-line
		(λ (edit event)
		  (let ([num-str
			 (call/text-keymap-initializer
			  (λ ()
			    (get-text-from-user
                             (string-constant goto-line)
                             (string-constant goto-line))))])
		    (when (string? num-str)
		      (let ([line-num (inexact->exact (string->number num-str))])
			(cond
                          [(and (number? line-num)
                                (= line-num (floor line-num))
                                (<= 1 line-num (+ (send edit last-paragraph) 1)))
                           (let ([pos (send edit paragraph-start-position 
                                            (sub1 line-num))])
                             (send edit set-position pos))]
                          [else
                           (message-box
                            (string-constant goto-line)
                            (format 
                             (string-constant goto-line-invalid-number)
                             num-str
                             (+ (send edit last-line) 1)))]))))
                  
		  #t)]
	       [goto-position
		(λ (edit event)
		  (let ([num-str
			 (call/text-keymap-initializer
			  (λ ()
			    (get-text-from-user 
                             (string-constant goto-position)
                             (string-constant goto-position))))])
		    (if (string? num-str)
			(let ([pos (string->number num-str)])
			  (when pos
                            (send edit set-position (sub1 pos))))))
		  #t)]
	       [repeater
		(λ (n edit)
		  (let* ([km (send edit get-keymap)]
			 [done
			  (λ ()
			    (send km set-break-sequence-callback void)
			    (send km remove-grab-key-function))])
		    (send km set-grab-key-function
			  (λ (name local-km edit event)
			    (if name
				(begin
				  (done)
				  (dynamic-wind
				   (λ ()
				     (send edit begin-edit-sequence))
				   (λ ()
				     (let loop ([n n])
				       (unless (zero? n)
					 (send local-km call-function name edit event)
					 (loop (sub1 n)))))
				   (λ ()
				     (send edit end-edit-sequence))))
				(let ([k (send event get-key-code)])
				  (if (and (char? k) (char<=? #\0 k #\9))
				      (set! n (+ (* n 10) (- (char->integer k)
							     (char->integer #\0))))
				      (begin
					(done)
					(dynamic-wind
					 (λ ()
					   (send edit begin-edit-sequence))
					 (λ ()
					   (let loop ([n n])
					     (unless (zero? n)
					       (send edit on-char event)
					       (loop (sub1 n)))))
					 (λ ()
					   (send edit end-edit-sequence)))))))			       
			    #t))
		    (send km set-break-sequence-callback done)
		    #t))]
	       [make-make-repeater
		(λ (n)
		  (λ (edit event)
		    (repeater n edit)))]
	       [current-macro '()] 
	       [building-macro #f] [build-macro-km #f] [build-protect? #f]
               [show/hide-keyboard-macro-icon
                (λ (edit on?)
                  (when (is-a? edit editor:basic<%>)
                    (let ([frame (send edit get-top-level-window)])
                      (when (is-a? frame frame:text-info<%>)
                        (send frame set-macro-recording on?)
                        (send frame update-shown)))))]
               
	       [do-macro
		(λ (edit event)
                  ; If c:x;e during record, copy the old macro
		  (when building-macro
		    (set! building-macro (append (reverse current-macro) 
						 (cdr building-macro))))
		  (let ([bm building-macro]
			[km (send edit get-keymap)])
		    (dynamic-wind
		     (λ ()
		       (set! building-macro #f)
		       (send edit begin-edit-sequence))
		     (λ ()
		       (let/ec escape
			 (for-each
			  (λ (f)
			    (let ([name (car f)]
				  [event (cdr f)])
			      (if name
				  (unless (send km call-function name edit event #t)
				    (escape #t))
				  (send edit on-char event))))
			  current-macro)))
		     (λ ()
		       (send edit end-edit-sequence)
		       (set! building-macro bm))))
		  #t)]
	       [start-macro
		(λ (edit event)
		  (if building-macro
		      (send build-macro-km break-sequence)
		      (letrec ([km (send edit get-keymap)]
			       [done
				(λ ()
				  (if build-protect?
				      (send km set-break-sequence-callback done)
				      (begin
					(set! building-macro #f)
                                        (show/hide-keyboard-macro-icon edit #f)
					(send km set-break-sequence-callback void)
					(send km remove-grab-key-function))))])
			(set! building-macro '())
                        (show/hide-keyboard-macro-icon edit #t)
			(set! build-macro-km km)
			(send km set-grab-key-function
			      (λ (name local-km edit event)
				(dynamic-wind
				 (λ ()
				   (set! build-protect? #t))
				 (λ ()
				   (if name
				       (send local-km call-function name edit event)
				       (send edit on-default-char event)))
				 (λ ()
				   (set! build-protect? #f)))
				(when building-macro
				  (set! building-macro 
					(cons (cons name event)
					      building-macro)))
				#t))
			(send km set-break-sequence-callback done)))
		  #t)]
	       [end-macro
		(λ (edit event)
		  (when building-macro
		    (set! current-macro (reverse building-macro))
		    (set! build-protect? #f)		    
		    (send build-macro-km break-sequence))
		  #t)]
	       [delete-key
		(λ (edit event)
		  (let ([kmap (send edit get-keymap)])
		    (send kmap call-function
			  (if (preferences:get 'framework:delete-forward?)
			      "delete-next-character"
			      "delete-previous-character")
			  edit event #t)))]
               
	       [toggle-overwrite
		(λ (edit event)
		  (send edit set-overwrite-mode
			(not (send edit get-overwrite-mode))))]
               
               [down-into-embedded-editor
                (λ (text event)
                  (let ([start (send text get-start-position)]
                        [end (send text get-end-position)])
                    (when (= start end)
                      (let* ([bx (box 0)]
                             [after-snip (send text find-snip start 'after-or-none bx)])
                        (cond
                          [(and (= (unbox bx) start)
                                after-snip
                                (is-a? after-snip editor-snip%))
                           (let ([embedded-editor (send after-snip get-editor)])
                             (when (is-a? embedded-editor text%)
                               (send embedded-editor set-position 0))
                             (send embedded-editor set-caret-owner #f 'global))]
                          [else
                           (let ([before-snip (send text find-snip start 'before-or-none bx)])
                             (when (and (= (+ (unbox bx) 1) start)
                                        before-snip
                                        (is-a? before-snip editor-snip%))
                              (let ([embedded-editor (send before-snip get-editor)])
                                (when (is-a? embedded-editor text%)
                                  (send embedded-editor set-position
                                        (send embedded-editor last-position)))
                                (send embedded-editor set-caret-owner #f 'global))))]))))
                  #t)]
                             
               [forward-to-next-embedded-editor
                (λ (text event)
                  (let ([start-pos (send text get-start-position)]
                        [end-pos (send text get-end-position)])
                    (when (= start-pos end-pos)
                      (let loop ([snip (send text find-snip start-pos 'after-or-none)])
                        (cond
                          [(not snip) (void)]
                          [(is-a? snip editor-snip%)
                           (send text set-position (send text get-snip-position snip))]
                          [else (loop (send snip next))]))))
                  #t)]
               
               [back-to-prev-embedded-editor
                (λ (text event)
                  (let ([start-pos (send text get-start-position)]
                        [end-pos (send text get-end-position)])
                    (when (= start-pos end-pos)
                      (let loop ([snip (send text find-snip start-pos 'before-or-none)])
                        (cond
                          [(not snip) (void)]
                          [(is-a? snip editor-snip%)
                           (send text set-position (+ (send text get-snip-position snip) 1))]
                          [else (loop (send snip previous))]))))
                  #t)]
               
               [up-out-of-embedded-editor
		(λ (text event)
                  (let ([start (send text get-start-position)]
                        [end (send text get-end-position)])
                    (when (= start end)
                      (let ([editor-admin (send text get-admin)])
                        (when (is-a? editor-admin editor-snip-editor-admin<%>)
                          (let* ([snip (send editor-admin get-snip)]
                                 [snip-admin (send snip get-admin)])
                            (when snip-admin
                              (let ([editor (send snip-admin get-editor)])
                                (when (is-a? editor text%)
                                  (let ([new-pos (send editor get-snip-position snip)])
                                    (send editor set-position new-pos new-pos))
                                  (send editor set-caret-owner #f 'display)))))))))
		  #t)]
               
               [make-read-only
                (λ (text event)
                  (send text lock #t)
                  #t)])
               
	  (λ (kmap)
	    (let* ([map (λ (key func) 
			  (send kmap map-function key func))]
		   [map-meta (λ (key func)
			       (send-map-function-meta kmap key func))]
		   [add (λ (name func)
			  (send kmap add-function name func))]
		   [add-m (λ (name func)
			    (send kmap add-function name func))])
              
              ; Map names to keyboard functions

	      (add "down-into-embedded-editor" down-into-embedded-editor)
              (add "up-out-of-embedded-editor" up-out-of-embedded-editor)
              (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor)
              (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor)

	      (add "toggle-overwrite" toggle-overwrite)
	      
	      (add "exit" (λ (edit event)
			    (let ([frame (send edit get-frame)])
			      (if (and frame
				       (is-a? frame frame:standard-menus<%>))
				  (send frame file-menu:quit)
				  (bell)))))
	      
	      (add "ring-bell" ring-bell)
	      
	      (add "insert-()-pair" (make-insert-brace-pair "(" ")"))
	      (add "insert-[]-pair" (make-insert-brace-pair "[" "]"))
	      (add "insert-{}-pair" (make-insert-brace-pair "{" "}"))
	      (add "insert-\"\"-pair" (make-insert-brace-pair "\"" "\""))
	      (add "insert-||-pair" (make-insert-brace-pair "|" "|"))
              (add "insert-lambda-template" insert-lambda-template)
	     
	      (add "toggle-anchor" toggle-anchor)
	      (add "center-view-on-line" center-view-on-line)
	      (add "collapse-space" collapse-space)
	      (add "remove-space" remove-space)
	      (add "collapse-newline" collapse-newline)
	      (add "open-line" open-line)
	      (add "transpose-chars" transpose-chars)
	      (add "transpose-words" transpose-words)
	      (add "capitalize-word" capitalize-word)
	      (add "upcase-word" upcase-word)
	      (add "downcase-word" downcase-word)
	      (add "kill-word" kill-word)
	      (add "backward-kill-word" backward-kill-word)
	      
	      (let loop ([n 9])
		(unless (negative? n)
		  (let ([s (number->string n)])
		    (add (string-append "command-repeat-" s)
			 (make-make-repeater n))
		    (loop (sub1 n)))))
	      
	      (add "keyboard-macro-run-saved" do-macro)
	      (add "keyboard-macro-start-record" start-macro)
	      (add "keyboard-macro-end-record" end-macro)
	      
	      (add-m "copy-clipboard" mouse-copy-clipboard)
	      (add-m "cut-clipboard" mouse-cut-clipboard)
	      (add-m "paste-clipboard" mouse-paste-clipboard)
	      (add-m "copy-click-region" copy-click-region)
	      (add-m "cut-click-region" cut-click-region)
	      (add-m "paste-click-region" paste-click-region)
	      (add-m "select-click-word" select-click-word)
	      (add-m "select-click-line" select-click-line)
	      
	      (add "goto-line" goto-line)
	      (add "goto-position" goto-position)
	      
	      (add "delete-key" delete-key)
              
	      (add "mouse-popup-menu" mouse-popup-menu)

	      (add "make-read-only" make-read-only)
              
              ; Map keys to functions
              
              (map-meta "c:down" "down-into-embedded-editor")
              (map "a:c:down" "down-into-embedded-editor")
              (map-meta "c:up" "up-out-of-embedded-editor")
              (map "a:c:up" "up-out-of-embedded-editor")
              (map-meta "c:right" "forward-to-next-embedded-editor")
              (map "a:c:right" "forward-to-next-embedded-editor")
              (map-meta "c:left" "back-to-prev-embedded-editor")
              (map "a:c:left" "back-to-prev-embedded-editor")
              
	      (map "c:g" "ring-bell")
	      (map-meta "c:g" "ring-bell")
	      (map "c:x;c:g" "ring-bell")
	      (map "c:c;c:g" "ring-bell")

              ;; This mapping is here to avoid having ctl-z insert "z"
              ;;  when the "Undo" menu item is disabled, because inserting
              ;;  "z" empties the redo stack
              (map "c:z" "ring-bell")
	      
	      (map-meta "(" "insert-()-pair")
	      (map-meta "[" "insert-[]-pair")
	      (map-meta "{" "insert-{}-pair")
	      (map-meta "\"" "insert-\"\"-pair")
	      (map-meta "|" "insert-||-pair")
	      (map-meta "s:l" "insert-lambda-template")

	      (map "c:p" "previous-line")
	      (map "up" "previous-line")
	      (map "s:c:p" "select-up")
	      (map "s:up" "select-up")
	      
	      (map "c:n" "next-line")
	      (map "down" "next-line")
	      (map "s:c:n" "select-down")
	      (map "s:down" "select-down")
	      
	      (map "c:e" "end-of-line")
	      (map "d:right" "end-of-line")
	      (map "m:right" "end-of-line")
	      (map "end" "end-of-line")
	      (map "m:s:right" "select-to-end-of-line")
	      (map "s:end" "select-to-end-of-line")
	      (map "s:c:e" "select-to-end-of-line")
	      
	      (map "c:a" "beginning-of-line")
	      (map "d:left" "beginning-of-line")
	      (map "m:left" "beginning-of-line")
	      (map "home" "beginning-of-line")
	      (map "m:s:left" "select-to-beginning-of-line")
	      (map "s:home" "select-to-beginning-of-line")
	      (map "s:c:a" "select-to-beginning-of-line")
	      
	      (map "c:f" "forward-character")
	      (map "right" "forward-character")
	      (map "s:c:f" "forward-select")
	      (map "s:right" "forward-select")
	      
	      (map "c:b" "backward-character")
	      (map "left" "backward-character")
	      (map "s:c:b" "backward-select")
	      (map "s:left" "backward-select")
	      
	      (map-meta "f" "forward-word")
	      (map "a:right" "forward-word")
	      (map "c:right" "forward-word")
	      (map-meta "s:f" "forward-select-word")
	      (map "a:s:right" "forward-select-word")
	      (map "c:s:right" "forward-select-word")
	      
	      (map-meta "b" "backward-word")
	      (map "a:left" "backward-word")
	      
	      (map "c:left" "backward-word")
	      (map-meta "s:b" "backward-select-word")
	      (map "a:s:left" "backward-select-word")
	      (map "c:s:left" "backward-select-word")
	      
	      (map-meta "<" "beginning-of-file")
	      (map "d:up" "beginning-of-file")
	      (map "c:home" "beginning-of-file")
	      (map "s:c:home" "select-to-beginning-of-file")
	      (map "s:d:up" "select-to-beginning-of-file")
	      
	      (map-meta ">" "end-of-file")
	      (map "d:down" "end-of-file")
	      (map "c:end" "end-of-file")
	      (map "s:c:end" "select-to-end-of-file")
	      (map "s:d:down" "select-to-end-of-file")
	      
	      (map "c:v" "next-page")
	      (map "a:down" "next-page")
	      (map "pagedown" "next-page")
	      (map "c:down" "next-page")
	      (map "s:c:v" "select-page-down")
	      (map "a:s:down" "select-page-down")
	      (map "s:pagedown" "select-page-down")
	      (map "s:c:down" "select-page-down")
	      
	      (map-meta "v" "previous-page")
	      (map "a:up" "previous-page")
	      (map "pageup" "previous-page")
	      (map "c:up" "previous-page")
	      (map-meta "s:v" "select-page-up")
	      (map "s:a:up" "select-page-up")
	      (map "s:pageup" "select-page-up")
	      (map "s:c:up" "select-page-up")
	      
	      (map "c:h" "delete-previous-character")
	      (map "c:d" "delete-next-character")
	      (map "del" "delete-key")
	      
	      (map-meta "d" "kill-word")
	      (map-meta "del" "backward-kill-word")
	      (map-meta "c" "capitalize-word")
	      (map-meta "u" "upcase-word")
	      (map-meta "l" "downcase-word")
	      
	      (map "c:l" "center-view-on-line")
	      
	      (map "c:k" "delete-to-end-of-line")
	      (map "c:y" "paste-clipboard")
	      (map-meta "y" "paste-next")
	      (map "a:v" "paste-clipboard")
	      (map "d:v" "paste-clipboard")
	      (map "c:_" "undo")
	      (map "c:/" "undo")
	      (map (format "~a" (integer->char 31)) "undo") ; for Windows - strange
	      (map "c:+" "redo")
	      (map "a:z" "undo")
	      (map "d:z" "undo")
	      (map "c:x;u" "undo")
	      (map "c:w" "cut-clipboard")
	      (map "a:x" "cut-clipboard")
	      (map "d:x" "cut-clipboard")
	      (map-meta "w" "copy-clipboard")
	      (map "a:c" "copy-clipboard")
	      (map "d:c" "copy-clipboard")
	      
	      (map "s:delete" "cut-clipboard")
	      (map "c:insert" "copy-clipboard")
	      (map "s:insert" "paste-clipboard")
              
	      (map-meta "space" "collapse-space")
              ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards.
	      (map "c:x;c:o" "collapse-newline")
	      (map "c:o" "open-line")
	      (map "c:t" "transpose-chars")
	      (map-meta "t" "transpose-words")
	      
	      (map "c:space" "toggle-anchor")
	      
	      (map "insert" "toggle-overwrite")
	      (map-meta "o" "toggle-overwrite")
	      
	      (map-meta "g" "goto-line")
	      (map-meta "p" "goto-position")
	      
	      (map "c:u" "command-repeat-0")
	      (let loop ([n 9])
		(unless (negative? n)
		  (let ([s (number->string n)])
		    (map-meta s (string-append "command-repeat-" s))
		    (loop (sub1 n)))))
	      
	      (map "c:x;e" "keyboard-macro-run-saved")
	      (map "c:x;(" "keyboard-macro-start-record")
	      (map "c:x;)" "keyboard-macro-end-record")
	      
	      (map "leftbuttontriple" "select-click-line")
	      (map "leftbuttondouble" "select-click-word")
	      
	      ;; the "roller ball" mice map clicking the ball to button 2.
	      (unless (eq? (system-type) 'windows)
		(map "middlebutton" "paste-click-region"))
              
	      (map ":rightbuttonseq" "mouse-popup-menu")
              
              (map "c:c;c:r" "make-read-only")
              ))))
      
      (define setup-search
	(let* ([send-frame
		(λ (invoke-method)
		  (λ (edit event)
		    (let ([frame
			   (cond
                             [(is-a? edit editor<%>)
                              (let ([canvas (send edit get-active-canvas)])
                                (and canvas
                                     (send canvas get-top-level-window)))]
                             [(is-a? edit area<%>)
                              (send edit get-top-level-window)]
                             [else #f])])
		      (if frame
			  (invoke-method frame)
			  (bell)))
		    #t))])
	  (λ (kmap)
	    (let* ([map (λ (key func) 
			  (send kmap map-function key func))]
		   [map-meta (λ (key func)
			       (send-map-function-meta kmap key func))]
		   [add (λ (name func)
			  (send kmap add-function name func))]
		   [add-m (λ (name func)
			    (send kmap add-function name func))])
	      
	      (add "move-to-search-or-search" 
		   (send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1
	      (add "move-to-search-or-reverse-search" 
		   (send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
	      (add "find-string-again" 
		   (send-frame (λ (f) (send f search-again)))) ;; key 2
	      (add "toggle-search-focus" 
		   (send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3
	      (add "hide-search" 
		   (send-frame (λ (f) (send f hide-search)))) ;; key 4
	      
	      (case (system-type)
		[(unix)
		 (map "c:s" "move-to-search-or-search")
		 (map-meta "%" "move-to-search-or-search")
		 (map "c:r" "move-to-search-or-reverse-search")
		 (map "f3" "find-string-again")
		 (map "c:i" "toggle-search-focus")
		 (map "c:g" "hide-search")]
		[(windows)
		 (map "c:r" "move-to-search-or-reverse-search")
		 (map "f3" "find-string-again")
		 (map "c:g" "find-string-again")	     
                 
		 ;; covered by menu
                 ;(map "c:f" "move-to-search-or-search")
                 
		 (map "c:i" "toggle-search-focus")]
		[(macos macosx)
		 (map "c:s" "move-to-search-or-search")
		 (map "c:g" "hide-search")
                 
		 ;; covered by menu
                 ;(map "d:f" "move-to-search-or-search")
                 
		 (map "c:r" "move-to-search-or-reverse-search")
		 (map "d:g" "find-string-again")
		 (map "c:i" "toggle-search-focus")])))))
      
      (define setup-file
	(let* ([get-outer-editor ;; : text% -> text%
                ;; returns the outermost editor, if this editor is nested in an editor snip.
                (λ (edit)
                  (let loop ([edit edit])
                    (let ([admin (send edit get-admin)])
                      (cond
                        [(is-a? admin editor-snip-editor-admin<%>)
                         (loop (send (send (send admin get-snip) get-admin) get-editor))]
                        [else edit]))))]
               [save-file-as
		(λ (this-edit event)
                  (let ([edit (get-outer-editor this-edit)])
                    (parameterize ([finder:dialog-parent-parameter 
                                    (and (is-a? edit editor:basic<%>)
                                         (send edit get-top-level-window))])
                      (let ([file (finder:put-file)])
                        (when file
                          (send edit save-file/gui-error file)))))
                  #t)]
	       [save-file
		(λ (this-edit event)
                  (let ([edit (get-outer-editor this-edit)])
                    (if (send edit get-filename)
                        (send edit save-file/gui-error)
                        (save-file-as edit event)))
		  #t)]
	       [load-file
		(λ (edit event)
		  (handler:open-file)
		  #t)])
	  (λ (kmap)
	    (let* ([map (λ (key func) 
			  (send kmap map-function key func))]
		   [map-meta (λ (key func)
			       (send-map-function-meta kmap key func))]
		   [add (λ (name func)
			  (send kmap add-function name func))]
		   [add-m (λ (name func)
			    (send kmap add-function name func))])
	      
	      (add "save-file" save-file)
	      (add "save-file-as" save-file-as)
	      (add "load-file" load-file)
	      
	      (map "c:x;c:s" "save-file")
	      (map "d:s" "save-file")
	      (map "c:x;c:w" "save-file-as")
	      (map "c:x;c:f" "load-file")))))
      
      (define (setup-editor kmap)
	(let ([add/map
	       (λ (func op key)
		 (send kmap add-function
		       func
		       (λ (editor evt)
			 (send editor do-edit-operation op)))
		 (send kmap map-function
		       (string-append
			(case (system-type)
			  [(macosx macos) "d:"]
			  [(windows) "c:"]
			  [(unix) "a:"]
			  [else (error 'keymap.ss "unknown platform: ~s" (system-type))])
			key)
		       func))])
	  (add/map "editor-undo" 'undo "z")
	  (add/map "editor-redo" 'redo "y")
	  (add/map "editor-cut" 'cut "x")
	  (add/map "editor-copy" 'copy "c")
	  (add/map "editor-paste" 'paste "v")
	  (add/map "editor-select-all" 'select-all "a")))
      
      (define (generic-setup keymap)
	(add-editor-keymap-functions keymap)
	(add-pasteboard-keymap-functions keymap)
	(add-text-keymap-functions keymap))
      
      (define global (make-object aug-keymap%))
      (define global-main (make-object aug-keymap%))
      (send global chain-to-keymap global-main #t)
      (setup-global global-main)
      (generic-setup global-main)
      (define (get-global) global)
      
      (define file (make-object aug-keymap%))
      (setup-file file)
      (generic-setup file)
      (define (-get-file) file)
      
      (define search (make-object aug-keymap%))
      (generic-setup search)
      (setup-search search)
      (define (get-search) search)
      
      (define editor (make-object aug-keymap%))
      (setup-editor editor)
      (define (get-editor) editor)
      
      (define (call/text-keymap-initializer thunk)
	(let ([ctki (current-text-keymap-initializer)])
	  (parameterize ([current-text-keymap-initializer
			  (λ (keymap)
			    (send keymap chain-to-keymap global #t)
			    (ctki keymap))])
	    (thunk)))))))
