(module command-keymap mzscheme
  (require (lib "etc.ss")
           (lib "class.ss")
           (lib "framework.ss" "framework")
           (lib "mred.ss" "mred")
           (lib "list.ss")
           "structures.ss"
           (prefix preferences: "diva-preferences.ss"))
  
  (provide make-command-keymap)
  
  
  (define make-command-keymap
    (lambda (window-text to-insert-mode to-insert-mode/cmd diva-message diva-question interpreter)
      (let ([command-keymap (make-object keymap:aug-keymap%)])
        
        (define (make-command-to-argument-mode command title)
          (let ([default ""])
            (lambda ()
              (diva-question title
                             default
                             argument-to-command-mode
                             (lambda (text)
                               (set! default text)
                               (interpreter (make-Verb (make-Command command)
                                                       false
                                                       (make-WhatN (make-Symbol-Noun
                                                                    (string->symbol text)))))
                               (argument-to-command-mode))))))
        
        (define (argument-to-command-mode)
          (let [(canvas (send window-text get-canvas))]
            (when canvas
              (send canvas focus))))
        
        (define (command command)
          (lambda (any event)
	    (interpreter (make-Verb (make-Command command) false false))))
        
        (define insert-before-ast 
          (make-Verb (make-Command 'Insert) (make-Loc (make-Before) false) false))
        (define insert-after-ast  
          (make-Verb (make-Command 'Insert) (make-Loc (make-After) false) false))
        
        
        (define (insert ast/false edit?)
          (lambda (any event)
            (when ast/false
		  (interpreter ast/false))
            (to-insert-mode edit?)))

        (define (insert/cmd cmd edit?)
          (lambda (any event)
            (to-insert-mode/cmd edit? cmd)))

        (define (argument command title)
          (let ([command/default (make-command-to-argument-mode command title)])
            (lambda (any event)
              (command/default))))
        
        (add-text-keymap-functions command-keymap)
        
        (send command-keymap add-function "diva:enter" (command 'Enter))
        (send command-keymap add-function "diva:indent"    (command 'Indent))
        (send command-keymap add-function "diva:before-this" (insert insert-before-ast false))
        (send command-keymap add-function "diva:after-this" (insert insert-after-ast false))
        (send command-keymap add-function "diva:insert" (insert false false))
        (send command-keymap add-function "diva:up"        (command 'Up))
        (send command-keymap add-function "diva:down"        (command 'Down))
        (send command-keymap add-function "diva:out"       (command 'Out))
        (send command-keymap add-function "diva:backward"  (command 'Backward))
        (send command-keymap add-function "diva:forward"   (command 'Forward))
        (send command-keymap add-function "diva:next"      (command 'Next))
        (send command-keymap add-function "diva:previous"  (command 'Previous))
        (send command-keymap add-function "diva:select" (argument 'Select "select"))
        (send command-keymap add-function "diva:search-forward"  (argument 'Search-Forward  "search forward"))
        (send command-keymap add-function "diva:search-backward" (argument 'Search-Backward "search backward"))
        (send command-keymap add-function "diva:copy"      (command 'Copy))
        (send command-keymap add-function "diva:cut"       (command 'Cut))
        (send command-keymap add-function "diva:paste"     (command 'Paste))
        (send command-keymap add-function "diva:undo"      (command 'Undo))
        (send command-keymap add-function "diva:cancel"    (command 'Cancel))
        (send command-keymap add-function "diva:redo"      (command 'Redo))
        (send command-keymap add-function "diva:delete"    (command 'Delete))
        (send command-keymap add-function "diva:push"       (command 'Push))
        (send command-keymap add-function "diva:bring"     (command 'Bring))
        (send command-keymap add-function "diva:exchange"  (command 'Exchange))
        (send command-keymap add-function "diva:mark"      (command 'Mark))
        (send command-keymap add-function "diva:holder"    (command 'Holder))
        (send command-keymap add-function "diva:transpose" (command 'Transpose))
        (send command-keymap add-function "diva:find-tag" (argument 'Tag "Find tag"))
        (send command-keymap add-function "diva:magic"     (command 'Magic))
        (send command-keymap add-function "diva:join"      (command 'Join))
        (send command-keymap add-function "diva:unmark"    (command 'UnMark))
        (send command-keymap add-function "diva:open" (insert/cmd 'Open false))
        (send command-keymap add-function "diva:open-square" (insert/cmd 'Open-Square false))
        (send command-keymap add-function "diva:close"     (command 'Close))
        (send command-keymap add-function "diva:search-top" (argument 'Search-Top "search top" ))
        (send command-keymap add-function "diva:search-bottom" (argument 'Search-Bottom "search bottom"))
        (send command-keymap add-function "diva:definition" (argument 'Definition "definition"))
        (send command-keymap add-function "diva:usage" (argument 'Usage "usage"))
        (send command-keymap add-function "diva:younger"     (command 'Younger))
        (send command-keymap add-function "diva:older"      (command 'Older))
        (send command-keymap add-function "diva:first"     (command 'First))
        (send command-keymap add-function "diva:last"      (command 'Last))
        (send command-keymap add-function "diva:extend-selection" (command 'Extend-Selection))
        (send command-keymap add-function "diva:edit-symbol" (insert false true))
        (send command-keymap add-function "diva:disabled" void)
        (for-each
         (lambda (key) (send command-keymap map-function key "diva:disabled"))
         `("1" "2" "3" "4" "5" "6" "7" "8" "9" "0"
               "!" "@" "#" "$" "%" "^" "&" "*"
               "_" "-" "=" "+"
               "backspace" "delete" "|"
               "`" "\"" "," "'" "<" ">" "/" "\\"  "?"
               "insert" "colon"
               ,@(map (lambda (ch) (format "s:~a" ch))
                      (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
               ,@(map string
                      (string->list "abcdefghijklmnopqrstuvwxyz"))))
        
        (preferences:install-command-mode-bindings command-keymap)
        
        
        command-keymap))))