(module insert-keymap mzscheme
  (require (lib "etc.ss")
	   (lib "list.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred")
           (only (lib "1.ss" "srfi") circular-list)
           (lib "framework.ss" "framework")
           "traversal.ss"
           "utilities.ss"
           "structures.ss"
           "choose-paren.ss"
           "in-something.ss"
           "rope.ss"
           "text-rope-mixin.ss"
           (prefix action: "actions.ss")
           (prefix preferences: "diva-preferences.ss"))
  
  
  (provide make-insert-mode)
  
  ;;
  ;; DEBUG STUFFS
  ;;
  
  ;; diva-debug : boolean
  (define diva-debug false)
  
  ;; This function prints something if and only if diva-debug is true.
  (define (diva-printf text . args)
    (when diva-debug
      (apply printf text args)))
  
  (define (alt/meta-prefix str)
    (format "~a~a" (case (system-type)
                     [(macosx macos) "d:"]
                     [(windows)      "m:"]
                     [(unix)         "m:"]
		     [else           "m:"]) str))
  
  
  
  ;; even it was forgotten in the documentation, key identifiers "back" and "backspace" are the same for map-function.
  ;;
  (define (make-rigid-keymap keymap fun)
    (send keymap add-function "diva:rigid-rid-off" fun)
    
    (send keymap map-function "up"      "diva:rigid-rid-off")
    (send keymap map-function "down"    "diva:rigid-rid-off")
    
    (send keymap map-function "home"     "diva:rigid-rid-off")
    (send keymap map-function "end"      "diva:rigid-rid-off")
    (send keymap map-function "pageup"   "diva:rigid-rid-off")
    (send keymap map-function "pagedown" "diva:rigid-rid-off")
    
    (send keymap map-function "delete"   "diva:rigid-rid-off")
    (send keymap map-function "insert"   "diva:rigid-rid-off")
    
    (send keymap map-function "leftbutton"   "diva:rigid-rid-off")
    (send keymap map-function "rightbutton"  "diva:rigid-rid-off")
    (send keymap map-function "middlebutton" "diva:rigid-rid-off")
    
    (send keymap set-grab-key-function
	  (lambda (str km editor event)
            (define whitespace
              (list #\nul #\rubout #\backspace #\tab #\return #\space
                    #\linefeed #\newline #\null #\page #\vtab))
            (diva-printf "GRAB KEY FUNCTION WAS CALLED for TEXT: str:~a km: editor: event:%~a%'~n" str (send event get-key-code))
            (if str
                (if ((prefix/string? "diva:") str) false true)
                (let ([key-code (send event get-key-code)])
                  (cond
                    [(and (char? key-code)
                          (not (member key-code whitespace)))
                     (send editor insert key-code)
                     true]
                    [else
                     false]))))))
  
  
  
  (define (blank-string? text)
    (let loop ([i 0])
      (cond
        [(= i (string-length text))
         #t]
        [(char-whitespace? (string-ref text i))
         (loop (add1 i))]
        [else #f])))
  
  
  ;;
  ;; The Insertion Mode
  ;;
  
  ;; A Pending is a (make-Pending a-world a-sym)
  ;; where a-World is a world, and a-sym is a member of '(Open Open-Square).
  ;; If the user starts typing "(...)", this is a signal that there might be
  ;; possible expansion by templates triggered by parens.
  ;; FIXME: this design is slightly convoluted. What would be a better way?
  (define-struct Pending (world symbol))
  
  
  ;; FIXME: if this takes so many parameters, there is a structural problem.
  (define make-insert-mode
    (lambda (window diva-message get-world set-world set-on-focus-lost
                    set-after-insert-callback set-after-delete-callback
                    interpret! post-exit-hook cmd edit?)
      
      
      ;; consume-text: World Pending rope -> void
      ;; Send the new text to be filled into the buffer.
      ;; The templating system forces us to consider if the insertion
      ;; is based on the sequence (Open X) or just regular X.
      (define (consume-text world pending-open a-rope)
        (if pending-open
            ;; possible templating with open parens
            (interpret! (Pending-world pending-open)
                        (make-Verb (make-Command (Pending-symbol pending-open))
                                   false
                                   (make-WhatN
                                    (make-Rope-Noun a-rope))))
            
            ;; possible templating without open parens
            (interpret! world
                        (make-Verb (make-InsertRope-Cmd a-rope)
                                   false
                                   false))))
      
      
      (define (consume-cmd world symbol)
        (interpret! world (make-Verb (make-Command symbol) false false)))
      
      (let ()
        
        (define world-at-beginning-of-insert #f)
        (define pending-open false)
        (define magic-options-lst false)
        (define magic-option-base false)
        
        (define left-edge-of-insert (send window get-start-position))
        (define right-edge-of-insert (send window get-start-position))
        
        (define (insert-color)
          (preferences:get ' framework:paren-match-color))
        
        (define clear-highlight (lambda () (void)))
        
        (define (get-text)
          (send window get-text left-edge-of-insert right-edge-of-insert))
        
        ;; get-rope: -> rope
        ;; Returns the contents between the left and right edge of the
        ;; insertion point.
        (define (get-rope)
          (read-subrope-in-text window left-edge-of-insert
                                (- right-edge-of-insert left-edge-of-insert)))
        
        (define (get-text-to-cursor)
          (send window get-text left-edge-of-insert (send window get-start-position)))
        
        (define (set-text text)
          (send window insert text left-edge-of-insert (send window get-start-position) true))
        
        
        (define (set-insert&delete-callbacks)
          (set-after-insert-callback on-insert)
          (set-after-delete-callback on-delete))
        
        (define (unset-insert&delete-callbacks)
          (set-after-insert-callback void)
          (set-after-delete-callback void))

        
        (define (begin-symbol-insertion/nothing-pending)
          (set! pending-open false)
          (begin-symbol-insertion))
        
        
        (define (begin-symbol-edit)
          (let* ([world (get-world)]
                 [stx/false (find-pos-near (World-cursor-position world)
                                           (World-syntax-list world))]
                 [stx/false (and stx/false
                                 (first (append
                                         (find-all atomic/stx?
                                                   (list stx/false))
                                         (list #f))))])
            (cond
              [stx/false
               (let ([original-pos (send window get-end-position)])
                 (set-world (action:select/stx world stx/false))
                 (begin-symbol (send window get-start-position)
                               (send window get-end-position))
                 (send window diva:set-selection-position
                       (clamp original-pos
                              (send window get-start-position)
                              (send window get-end-position)))
                 (set-insert&delete-callbacks))]
              [else
               (begin-symbol-insertion)])))
        
        
        
        
        (define (begin-symbol-insertion)
          (define left-point (send window get-start-position))
          
          (define need-space-before
            (and (not (= 0 left-point))
                 (not (eq? #\space
                           (send window get-character (sub1 left-point))))))
          
          (define need-space-after
            (or (= (string-length (send window get-text))
                   left-point)
                (not (eq? #\space
                          (send window get-character (add1 left-point))))))

          (define (prepare-insertion-point!)
            (if need-space-before
                (begin-symbol (add1 left-point) (add1 left-point))
                (begin-symbol left-point left-point))
            (unset-insert&delete-callbacks)
            (unless (empty-selection?)
              (send window delete))
            (when need-space-before
              (send window insert " "))
            (when need-space-after
              (send window insert " ")
              (send window diva:set-selection-position
                    (max (sub1 (send window get-end-position)) 0)))
            (set-insert&delete-callbacks))
          
          (prepare-insertion-point!)
          (fill-highlight!))
        
        
        (define (begin-symbol start-position end-position)
          (diva-message "")
          (set! left-edge-of-insert start-position)
          (set! right-edge-of-insert end-position)
          (fill-highlight!) 
          (set! world-at-beginning-of-insert (get-world))
          (set! magic-options-lst false)
          (set! magic-option-base false))
        
        
        (define (crop n)
          (clamp n 0 (string-length (send window get-text))))

        
        ;; empty-selection?: -> boolean
        ;; returns true if the selection is empty.
        (define (empty-selection?)
          (define start (box 0))
          (define end (box 0))
          (send window get-position start end)
          (= (unbox start) (unbox end)))
  
        
        ;; clamp: number number number -> number
        ;; clamp x between low and high.
        (define (clamp x low high)
          (min (max x low) high))
        
        
        (define (snap-to-edges)
          (let ([snapped-pos
                 (clamp (send window get-start-position)
                        left-edge-of-insert right-edge-of-insert)])
            (unless (= snapped-pos (send window get-start-position))
              (send window diva:set-selection-position snapped-pos))))
        
        (define (move-up)
          (send window move-position 'up)
          (snap-to-edges))
        
        (define (move-down)
          (send window move-position 'down)
          (snap-to-edges))
        
        (define (move-left)
          (send window move-position 'left)
          (snap-to-edges))
        
        (define (move-right)
          (send window move-position 'right)
          (snap-to-edges))
        
        (define (move-left*)
          (send window diva:set-selection-position left-edge-of-insert))
        
        (define (move-right*)
          (send window diva:set-selection-position right-edge-of-insert))
        
        
        (define (delete-backward)
          (cond
            [(= left-edge-of-insert (send window get-start-position))
             (void)
             ;; not quite working yet
             #;(eval-text&cmd 'Younger)
             ]
            [(< left-edge-of-insert
                (send window get-start-position))
             (send window delete)]))
        
        
        (define (delete-forward)
          (when (< (send window get-start-position)
                   right-edge-of-insert)
            (send window delete
                  (send window get-start-position)
                  (add1 (send window get-start-position)))))
        
        
        ;; copy-and-paste from framework/private/keymap.ss.
        (define (kill-word-forward)
          (let ([sel-start (send window get-start-position)]
                [sel-end (send window get-end-position)])
            (let ([end-box (box sel-end)])
              (send window find-wordbreak #f end-box 'caret)
              (send window kill
                    0
                    sel-start
                    (min right-edge-of-insert (unbox end-box))))))
        
        
        (define (kill-word-backward)
          (let ([sel-start (send window get-start-position)]
                [sel-end (send window get-end-position)])
            (let ([start-box (box sel-start)])
              (send window find-wordbreak start-box #f 'caret)
              (send window kill
                    0
                    (max left-edge-of-insert (unbox start-box))
                    sel-end))))

        
        (define (fill-highlight!)
          (clear-highlight)
          (local ((define left-
                    (cond
                      [(= (send window
                                position-line left-edge-of-insert)
                          (send window
                                position-line (crop (sub1 left-edge-of-insert))))
                       (crop (sub1 left-edge-of-insert))]
                      [else
                       left-edge-of-insert])))
            (set! clear-highlight
                  (send window highlight-range
                        left-
                        (crop (add1 right-edge-of-insert))
                        (insert-color)))))
        
        
        ;; on-insert: number number -> void
        ;; When new text is inserted into the window in insert mode, we
        ;; want to extend the insert point's highlighted region.
        (define (on-insert start length)
          (set! right-edge-of-insert (+ right-edge-of-insert length))
          (fill-highlight!))
        
        
        (define (on-delete start length)
          (set! right-edge-of-insert (- right-edge-of-insert length))
          (fill-highlight!))
                
        
        (define (invalid-insert? text)
          (with-handlers
              ([exn:fail? (lambda (exn) (exn-message exn))])
            (read (open-input-string text))
            #f))
        
        (define (eval-text)
          (local
              ((define txt (get-text))
               (define closer (in-something? txt))
               (define a-rope (get-rope)))
            (unless (blank-string? txt)
              (local ((define closed-rope
                        (cond [closer
                               (rope-append a-rope (string->rope closer))]
                              [else a-rope])))
                (let ([txt (if closer
                               (format "~a~a" txt closer)
                               txt)])
                  (consume-text world-at-beginning-of-insert
                                pending-open closed-rope)
                  (begin-symbol-insertion/nothing-pending))))))
        
        
        (define (eval-cmd symbol)
          (consume-cmd world-at-beginning-of-insert symbol)
          
          (if (or (eq? symbol 'Open)
                  (eq? symbol 'Open-Square))
              (begin
                (set! pending-open (make-Pending world-at-beginning-of-insert symbol))
                (begin-symbol-insertion))
              (begin-symbol-insertion/nothing-pending)))
        
        (define (eval-text&cmd symbol)
          (let ([start (box 0)]
                [end (box 0)])
            (eval-text)
            (eval-cmd symbol)))
        
        (define (make-circular lst) (apply circular-list lst))
        
        (define (magic-expand-insertion-text)
          (define quote-prefix "^([\"#'`,@]*)")
          
          (define (get-unmagic-prefix)
            (second (regexp-match quote-prefix (get-text))))
          
          (define (get-magic-text)
            (regexp-replace quote-prefix (get-text) ""))
          
          (define (consume-magic)
            (set-text (string-append (get-unmagic-prefix)
                                     (first magic-options-lst)))
            (diva-message "")
            (set! magic-option-base (first magic-options-lst))
            (set! magic-options-lst (rest magic-options-lst)))

          (cond
            [(and magic-option-base
                  (string=? magic-option-base (get-magic-text)))
             (consume-magic)]
            [else
             (let* ([options ;; options guaranteed not-empty: contains at least (get-text).
                     (action:magic-options
                      world-at-beginning-of-insert
                           left-edge-of-insert
                           (string->symbol (get-magic-text)))])
               (set! magic-options-lst (rest (make-circular options)))
               (cond 
                 [(empty? (rest options))
                  (diva-message
                   (format "no completion for ~a" (get-magic-text)))]
                 [else
                  (consume-magic)]))]))
        
        
        (define (revert&exit)
          (set-world world-at-beginning-of-insert)
          (exit))
        
        (define (consume&exit)
          (if (blank-string? (get-text))
              (revert&exit)
              (begin
                (eval-text)
                (set-world world-at-beginning-of-insert)
                (exit))))
        
        
        (define this-insert-mode-exited? false)
        (define (exit)
          (send (send window get-keymap) remove-chained-keymap insert-keymap)
          (clear-highlight)
          (set-on-focus-lost (lambda () (void)))
          (unset-insert&delete-callbacks)
          (post-exit-hook)
          (set! this-insert-mode-exited? true))
        
        
        ;; Returns a new event handler that can handle failure.
        (define-syntax (wrap-up stx)
          (syntax-case stx ()
            [(wrap-up fun ...)
             (syntax/loc stx
               (wrap-up* (lambda () fun) ...))]))
        
        (define (wrap-up* . thunks)
          (lambda (any event)
            (dynamic-wind
             (lambda () (send window begin-edit-sequence))
             (lambda () 
               (with-handlers ([voice-exn? (lambda (exn)
                                             (diva-message (voice-exn-message exn))
                                             (exit))])
                 (for-each (lambda (t) (t)) thunks)))
             (lambda () (send window end-edit-sequence)))))
        
        
        (define (maybe-literal* c  . thunks)
          (if (in-something? (get-text-to-cursor))
              (send window insert c)
              (for-each (lambda (t) (t)) thunks)))
        
        
        ;; Slightly special command here, since we need to communicate with
        ;; the editor.
        (define ((open-paren/contextual literal default-cmd) editor evt)
          ((wrap-up (maybe-literal
                     literal
                     (eval-text&cmd (get-contextual-open-cmd editor default-cmd))))
           editor evt))
        
        
        (define-syntax (maybe-literal stx)
          (syntax-case stx ()
            [(_ c e ...)
             (syntax/loc stx
               (maybe-literal* c (lambda () e) ...))]))
        
        (define (magic-or-pass)
          (if (= (string-length (get-text)) 0)
              (eval-text&cmd 'Pass-Wrap)
              (magic-expand-insertion-text)))
        
        (define insert-keymap (make-object keymap:aug-keymap%))
        
        ;; setting up callbacks
        (make-rigid-keymap insert-keymap void)
        
        (send insert-keymap add-function "diva:exit"        (wrap-up (consume&exit)))
        (send insert-keymap add-function "diva:cancel"      (wrap-up (revert&exit)))
        
        (send insert-keymap add-function "diva:delete-backward" (wrap-up (delete-backward)))
        (send insert-keymap add-function "diva:delete-forward" (wrap-up (delete-forward)))
        
        (send insert-keymap add-function "diva:kill-word-forward" (wrap-up (kill-word-forward)))
        (send insert-keymap add-function "diva:kill-word-backward" (wrap-up (kill-word-backward)))
        
        
        (send insert-keymap add-function "diva:space" (wrap-up (maybe-literal #\space (eval-text))))
        
        (send insert-keymap add-function "diva:close" (wrap-up (maybe-literal #\) (eval-text&cmd 'Close))))
        (send insert-keymap add-function "diva:close-square" (wrap-up (maybe-literal #\] (eval-text&cmd 'Close))))
        (send insert-keymap add-function "diva:close-curly" (wrap-up (maybe-literal #\} (eval-text&cmd 'Close))))

        
        (send insert-keymap add-function "diva:open" (wrap-up (maybe-literal #\( (eval-text&cmd 'Open))))
        (send insert-keymap add-function "diva:open-square" (wrap-up (maybe-literal #\[ (eval-text&cmd 'Open))))
        (send insert-keymap add-function "diva:open-square/contextual" (open-paren/contextual #\[ 'Open)) 
        (send insert-keymap add-function "diva:open-curly" (wrap-up (maybe-literal #\{ (eval-text&cmd 'Open-Square))))
        
        (send insert-keymap add-function "diva:enter" (wrap-up (maybe-literal #\newline (eval-text&cmd 'Enter))))
        
        (send insert-keymap add-function "diva:indent" (wrap-up (eval-text&cmd 'Indent)))
        (send insert-keymap add-function "diva:magic"       (wrap-up (magic-expand-insertion-text)))
        (send insert-keymap add-function "diva:pass" (wrap-up (magic-or-pass)))
        (send insert-keymap add-function "diva:bring" (wrap-up (eval-text&cmd 'Bring)))
        
        (send insert-keymap add-function "diva:up" (wrap-up (move-up)))
        (send insert-keymap add-function "diva:down" (wrap-up (move-down)))
        (send insert-keymap add-function "diva:left" (wrap-up (move-left)))
        (send insert-keymap add-function "diva:right"        (wrap-up (move-right)))
        
        (send insert-keymap add-function "diva:left*"        (wrap-up (move-left*)))
        (send insert-keymap add-function "diva:right*"        (wrap-up (move-right*)))
        
        (preferences:install-insert-mode-bindings insert-keymap)
        
        (when this-insert-mode-exited?
          (error 'insert-keymap "Insert keymap used after it exited."))
        
        
        (set-on-focus-lost consume&exit)
        
        (unset-insert&delete-callbacks)
        
        (send (send window get-keymap) chain-to-keymap insert-keymap #t)
        
        (if edit? (begin-symbol-edit) (begin-symbol-insertion))
        (when cmd (eval-cmd cmd))))))