;;; canna.scm: Canna for uim.
;;;
;;; Copyright (c) 2003,2004 uim Project http://uim.freedesktop.org/
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. Neither the name of authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this software
;;;    without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;

(require "japanese.scm")
(require "generic-key.scm")
(require "generic.scm")

; variables
(define canna-init-lib-ok? #f)
(define canna-use-candidate-window? #t)
(define canna-candidate-op-count 1)
(define canna-nr-candidate-max 10)
(define canna-show-segment-separator? #f)
(define canna-segment-separator "|")
; TODO: support cannaserver on other host
(define canna-server-name #f)
;(define canna-server-name "localhost")
;(define canna-server-name "127.0.0.1")
;;; Key definition
(define-key canna-on-key? "<Control>\\")
(define-key canna-off-key? "<Control>\\")
(define-key canna-latin-key? "<Control>\\")
;(define-key canna-latin-key '("l" generic-on-key?))
(define-key canna-wide-latin-key? "L")
(define-key canna-hankaku-kana-key? '("<Control>q" "<Control>Q"))
(define-key canna-kana-toggle-key? "q")
(define-key canna-commit-as-opposite-kana-key? "Q")
(define-key canna-begin-conv-key? '(generic-begin-conv-key? generic-on-key?))
(define-key canna-commit-key? 'generic-commit-key?)
(define-key canna-extend-segment-key? '("<Control>o" "<Control>O" "<Shift>right"))
(define-key canna-shrink-segment-key? '("<Control>i" "<Control>I" "<Shift>left"))
(define-key canna-next-candidate-key? 'generic-next-candidate-key?)
(define-key canna-prev-candidate-key? 'generic-prev-candidate-key?)
;(define-key canna-next-page-key? 'generic-next-page-key?)
;(define-key canna-prev-page-key? 'generic-prev-page-key?)
(define-key canna-cancel-key? 'generic-cancel-key?)
(define-key canna-backspace-key? 'generic-backspace-key?)
(define-key canna-delete-key? 'generic-delete-key?)
;(define-key canna-kill-key? 'generic-kill-key?)
;(define-key canna-kill-backward-key? 'generic-kill-backward-key?)
(define-key canna-go-left-key? 'generic-go-left-key?)
(define-key canna-go-right-key? 'generic-go-right-key?)
(define-key canna-beginning-of-preedit-key? 'generic-beginning-of-preedit-key?)
(define-key canna-end-of-preedit-key? 'generic-end-of-preedit-key?)
(define-key canna-next-segment-key? 'generic-go-right-key?)
(define-key canna-prev-segment-key? 'generic-go-left-key?)

;;; access
(define (canna-context-id cc)
  (car (nthcdr 0 cc)))
(define (canna-context-set-id! cc id)
  (set-car! (nthcdr 0 cc) id))

(define (canna-context-on cc)
  (car (nthcdr 0 cc)))
(define (canna-context-set-on! cc s)
  (set-car! (nthcdr 0 cc) s))

(define (canna-context-state cc)
  (car (nthcdr 1 cc)))
(define (canna-context-set-state! cc st)
  (set-car! (nthcdr 1 cc) st))

(define (canna-context-cc-id cc)
  (car (nthcdr 2 cc)))
(define (canna-context-set-cc-id! cc id)
  (set-car! (nthcdr 2 cc) id))

(define (canna-context-left-string cc)
  (car (nthcdr 3 cc)))
(define (canna-context-set-left-string! cc str)
  (set-car! (nthcdr 3 cc) str))

(define (canna-context-right-string cc)
  (car (nthcdr 4 cc)))
(define (canna-context-set-right-string! cc str)
  (set-car! (nthcdr 4 cc) str))

(define (canna-context-rkc cc)
  (car (nthcdr 5 cc)))
(define (canna-context-set-rkc! cc rkc)
  (set-car! (nthcdr 5 cc) rkc))

(define (canna-context-index-list cc)
  (car (nthcdr 6 cc)))
(define (canna-context-set-index-list! cc lst)
  (set-car! (nthcdr 6 cc) lst))

(define (canna-context-cur-seg cc)
  (car (nthcdr 7 cc)))
(define (canna-context-set-cur-seg! cc seg)
  (set-car! (nthcdr 7 cc) seg))

(define (canna-context-candidate-window cc)
  (car (nthcdr 8 cc)))
(define (canna-context-set-candidate-window! cc f)
  (set-car! (nthcdr 8 cc) f))

(define (canna-context-candidate-op-count cc)
  (car (nthcdr 9 cc)))
(define (canna-context-set-candidate-op-count! cc c)
  (set-car! (nthcdr 9 cc) c))

(define (canna-context-wide-latin cc)
  (car (nthcdr 10 cc)))
(define (canna-context-set-wide-latin! cc c)
  (set-car! (nthcdr 10 cc) c))

(define (canna-context-kana-mode cc)
  (car (nthcdr 11 cc)))
(define (canna-context-set-kana-mode! cc c)
  (set-car! (nthcdr 11 cc) c))

(define (canna-context-commit-raw cc c)
  (car (nthcdr 12 cc)))

(define (canna-context-set-commit-raw! cc c)
  (set-car! (nthcdr 12 cc) c))

;;; on/off, state, canna-context-id, string, rkc, index-list, cur-seg, candidate-window, candidate-op-count, wide-latin, kana-mode
(define (canna-context-new)
  (let ((c '())
	(rkc (rk-context-new ja-rk-rule #t #f)))
    (set! c (copy-list '(() () () () () () () () () () () 0 #t #f)))
;    (canna-context-set-cc-id! c (if canna-init-lib-ok?
;				    (canna-lib-alloc-context) ()))
    (canna-context-set-cc-id! c (canna-lib-alloc-context))
    (canna-context-set-rkc! c rkc)
    (canna-flush c)
    (canna-context-set-on! c #f)
    c))

(define (canna-commit-raw cc id)
  (im-commit-raw id)
  (canna-context-set-commit-raw! cc #t))

(define canna-opposite-kana
  (lambda (kana)
    (cond
     ((= kana multi-segment-type-hiragana)
      multi-segment-type-katakana)
     ((= kana multi-segment-type-katakana)
      multi-segment-type-hiragana)
     ((= kana multi-segment-type-hankana)
      multi-segment-type-hiragana))))

(define (canna-context-kana-toggle cc)
  (let* ((kana (canna-context-kana-mode cc))
	 (opposite-kana (canna-opposite-kana kana)))
    (canna-context-set-kana-mode! cc opposite-kana)))

(define (canna-mode-handler id mode)
  (let* ((c (find-context id))
	 (cc (context-date c)))
    (canna-flush cc)
    (cond
     ((= mode multi-segment-mode-direct)
      (canna-context-set-on! cc #f)
      (canna-context-set-wide-latin! cc #f))
     ((= mode multi-segment-mode-hiragana)
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-hiragana))
     ((= mode multi-segment-mode-katakana)
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-katakana))
     ((= mode multi-segment-mode-wide-latin)
      (canna-context-set-on! cc #f)
      (canna-context-set-wide-latin! cc #t))
     ((= mode multi-segment-mode-hankana)
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-hankana)))
    (canna-update-preedit cc id))
  ())

(define (canna-flush cc)
  (rk-flush (canna-context-rkc cc))
  (canna-context-set-left-string! cc '())
  (canna-context-set-right-string! cc '())
  (canna-context-set-on! cc #t)
  (canna-context-set-state! cc #f)
  (canna-context-set-index-list! cc ())
  (canna-context-set-candidate-window! cc #f)
  (canna-context-set-candidate-op-count! cc 0))

(define (canna-begin-input cc)
  (canna-context-set-on! cc #t)
  (rk-flush (canna-context-rkc cc))
  (canna-context-set-state! cc #f))

(define (canna-update-preedit cc id)
  (if (canna-context-on cc)
      (if (canna-context-state cc)
	  (canna-compose-state-preedit cc id)
	  (canna-input-state-preedit cc id))
      (begin
	(im-clear-preedit id)
	(im-update-preedit id))))

(define (canna-append-string cc str)
  (and str
       (if (not (string? (car str)))
	   (begin
	     (canna-append-string cc (car str))
	     (canna-append-string cc (cdr str))
	     #f)
	   #t)
       (canna-context-set-left-string!
	cc (cons str (canna-context-left-string cc)))))

(define (canna-begin-conv cc)
  (let* ((cc-id (canna-context-cc-id cc))
	 (rkc (canna-context-rkc cc))
	 (kana (canna-context-kana-mode cc))
	 (last "")
	 (res))
    (set! res (rk-push-key-last! rkc))
    (if res
	(canna-append-string cc res))

    (canna-context-set-index-list!
     cc
     (multi-segment-make-index-list
      (canna-lib-begin-conversion
       cc-id
       (string-append
	(multi-segment-make-left-string (canna-context-left-string cc)
					multi-segment-type-hiragana)
	(multi-segment-make-right-string (canna-context-right-string cc)
					 multi-segment-type-hiragana))) #f))
    (canna-context-set-state! cc #t)
    (canna-context-set-cur-seg! cc 0)
    (rk-flush (canna-context-rkc cc))))

(define (canna-proc-input-state-no-preedit cc id key key-state)
  (let
      ((rkc (canna-context-rkc cc))
       (direct (ja-direct (charcode->string key))))
    (cond
     ((canna-wide-latin-key? key key-state)
      (begin
	(canna-flush cc)
	(canna-context-set-on! cc #f)
	(canna-context-set-wide-latin! cc #t)
	(canna-update-mode cc id)
	(canna-update-prop-label cc id)))
     
     ((canna-latin-key? key key-state)
      (begin
	(canna-flush cc)
	(canna-context-set-on! cc #f)
	(canna-context-set-wide-latin! cc #f)
	(canna-update-mode cc id)
	(canna-update-prop-label cc id)))
     
     ((canna-backspace-key? key key-state)
      (canna-commit-raw cc id))
     
     ((canna-delete-key? key key-state)
      (canna-commit-raw cc id))
     
     ((canna-hankaku-kana-key? key key-state)
      (begin 
	(canna-context-set-kana-mode! cc canna-type-hankana)
	(canna-update-mode cc id)
	(canna-update-prop-label cc id)))
     
     ((canna-kana-toggle-key? key key-state)
      (begin 
	(canna-context-kana-toggle cc)
	(canna-update-mode cc id)
	(canna-update-prop-label cc id)))
     
     ;; modifiers (except shift) => ignore
     ((and (modifier-key-mask key-state)
	   (not (shift-key-mask key-state)))
      (canna-commit-raw cc id))
     
     ;; direct key => commit
     (direct
      (im-commit id direct))
     (else
      (let* ((key-str (charcode->string
		       (if using-kana-table?
			   key
			   (to-lower-char key))))
	     (res (rk-push-key! rkc key-str)))
	(if res
	    (canna-append-string cc res)
	    (if (not (rk-pending rkc)
		       (canna-commit-raw cc id)))))))))

(define (canna-has-preedit? cc)
  (or
   (> (length (canna-context-left-string cc)) 0)
   (> (length (canna-context-right-string cc)) 0)
   (> (length (rk-pending (canna-context-rkc cc))) 0)))


(define (canna-proc-input-state-with-preedit cc id key key-state)
  (let ((rkc (canna-context-rkc cc))
	(cc-id (canna-context-cc-id cc))
	(kana (canna-context-kana-mode cc)))

    (cond
     ;; begin conversion
     ((canna-begin-conv-key? key key-state)
      (canna-begin-conv cc))
;     ((and (canna-begin-conv-key? key key-state)
;	   canna-init-lib-ok?)
;      (canna-begin-conv cc))
     ;; backspace
     ((canna-backspace-key? key key-state)
      (begin
	(canna-lib-reset-conversion cc-id)
	(if (not (rk-backspace rkc))
	    (if (canna-context-left-string cc)
		(canna-context-set-left-string!
		 cc
		 (cdr (canna-context-left-string cc)))))))
     ;; delete
     ((canna-delete-key? key key-state)
      (if (not (rk-delete rkc))
	  (if (canna-context-right-string cc)
	      (canna-context-set-right-string!
	       cc
	       (cdr (canna-context-right-string cc))))))
     ;; ひらがなモードでカタカナを確定する
     ((canna-commit-as-opposite-kana-key? key key-state)
      (begin
	(im-commit
	 id
	 (string-append
	  (multi-segment-make-left-string (canna-context-left-string cc)
					  (canna-opposite-kana kana))
	  (multi-segment-make-right-string (canna-context-right-string cc)
					   (canna-opposite-kana kana))))
	(canna-flush cc)))
     ;; 現在のかなを確定後、ひらがな/カタカナモードを切り換える
     ((canna-kana-toggle-key? key key-state)
      (begin
	(im-commit
	 id
	 (string-append
	  (multi-segment-make-left-string (canna-context-left-string cc)
					  kana)
	  (multi-semgnet-make-right-string (canna-context-right-string cc)
					   kana)))
	(canna-flush cc)
	(canna-context-kana-toggle cc)
	(canna-update-mode cc id)
	(canna-update-prop-label cc id)))
     ;; cancel
     ((canna-cancel-key? key key-state)
      (canna-flush cc))
     ;; commit
     ((canna-commit-key? key key-state)
      (begin
	(im-commit
	 id
	 (string-append
	  (multi-segment-make-left-string (canna-context-left-string cc)
					  kana)
	  (rk-pending rkc)
	  (multi-segment-make-right-string (canna-context-right-string cc)
					   kana)))
	(canna-flush cc)))
     ;; left
     ((canna-go-left-key? key key-state)
      (begin
	(if (canna-context-left-string cc)
	    (let
		((c (car (canna-context-left-string cc))))
	      (canna-context-set-left-string!
	       cc (cdr (canna-context-left-string cc)))
	      (canna-context-set-right-string!
	       cc
	       (cons c (canna-context-right-string cc)))))))
     ;; right
     ((canna-go-right-key? key key-state)
      (begin
	(if (canna-context-right-string cc)
	    (let
		((c (car (canna-context-right-string cc))))
	      (canna-context-set-right-string!
	       cc (cdr (canna-context-right-string cc)))
	      (canna-append-string cc c)))))

     ;; beginning-of-preedit
     ((canna-beginning-of-preedit-key? key key-state)
      (if (canna-context-left-string cc)
	  (begin
	    (canna-context-set-right-string!
	     cc
	     (append
	      (reverse (canna-context-left-string cc))
	      (canna-context-right-string cc)))
	    (canna-context-set-left-string! cc ()))))

     ;; end-of-preedit
     ((canna-end-of-preedit-key? key key-state)
      (if (canna-context-right-string cc)
	  (begin
	    (canna-context-set-left-string!
	     cc
	     (append
	      (reverse (canna-context-right-string cc))
	      (canna-context-left-string cc)))
	      (canna-context-set-right-string! cc ()))))
;		   (rk-flush rkc)))

     ;; modifiers (except shift) => ignore
     ((and (modifier-key-mask key-state)
	      (not (shift-key-mask key-state)))
      (canna-commit-raw cc id))
     (else
      (let* ((key-str (charcode->string key))
	     (pend (rk-pending rkc))
	     (res (rk-push-key! rkc key-str)))
	(if (and res (not (string=? (car res) "")))
	    (canna-append-string cc res)
	    (if using-kana-table?
		(begin
		  (canna-append-string cc (list pend "" ""))
;     (set! key (to-lower-char key))
;     (let ((res)
;	   (key-str (charcode->string key)))
;       (set! res (rk-push-key! rkc key-str))
;       (if res
;	   (canna-append-string cc res))))))
))))))))

(define (canna-proc-input-state cc id key key-state)
  (if (canna-has-preedit? cc)
      (canna-proc-input-state-with-preedit cc id key key-state)
      (canna-proc-input-state-no-preedit cc id key key-state)))

(define (canna-pushback-preedit-segment-rec cc id idx nseg)
  (let ((cc-id (canna-context-cc-id cc)))
    (if (< idx nseg)
	(begin
	  (if (and
	       canna-show-segment-separator?
	       (< 0 idx))
	      (im-pushback-preedit
	       id
	       (bit-or preedit-separator
		       preedit-underline)
	       canna-segment-separator))
	  (im-pushback-preedit
	   id
	   (if (= idx (canna-context-cur-seg cc))
	       (+ preedit-reverse preedit-cursor)
	       preedit-underline)
	   (canna-lib-get-nth-candidate
	      cc-id idx
	      (nth idx (canna-context-index-list cc))))
	    (canna-pushback-preedit-segment-rec cc id (+ idx 1) nseg)))))

(define (canna-compose-state-preedit cc id)
  (im-clear-preedit id)
  (canna-pushback-preedit-segment-rec
   cc id
   0 (length (canna-context-index-list cc)))
  (im-update-preedit id))

(define (canna-input-state-preedit cc id)
  (let ((rkc (canna-context-rkc cc))
	(kana (canna-context-kana-mode cc)))
    (im-clear-preedit id)
    (im-pushback-preedit
     id preedit-underline
     (multi-segment-make-left-string (canna-context-left-string cc) kana))
    (im-pushback-preedit id preedit-underline
			 (rk-pending rkc))
    (if (canna-has-preedit? cc)
	(im-pushback-preedit id preedit-cursor ""))
    (im-pushback-preedit
     id preedit-underline
     (multi-segment-make-right-string (canna-context-right-string cc) kana))
    (im-update-preedit id)))

(define (canna-get-commit-string cc idx nseg)
  (let ((cc-id (canna-context-cc-id cc)))
    (if (< idx nseg)
	(string-append
	 (canna-lib-get-nth-candidate
	  cc-id idx
	  (nth idx (canna-context-index-list cc)))
	 (canna-get-commit-string cc (+ idx 1) nseg))
	"")))

(define (canna-commit-string cc idx nseg)
  (let ((cc-id (canna-context-cc-id cc)))
    (if (< idx nseg)
	(begin
	  (canna-lib-commit-segment
	   cc-id idx (nth idx (canna-context-index-list cc)))
	  (canna-commit-string cc
			       (+ idx 1) nseg))
	#f)))

(define (canna-do-commit cc id)
    (canna-reset-candidate-window cc id)
    (im-commit id
	       (canna-get-commit-string
		cc 0
		(length (canna-context-index-list cc))))
    (canna-commit-string
     cc 0
     (length (canna-context-index-list cc)))
    (canna-flush cc))

(define (canna-init-handler id arg)
  (let ((c (find-context id)))
    (set-context-data! c (canna-context-new))
    (im-clear-mode-list id)
    (im-pushback-mode-list id "直接入力")
    (im-pushback-mode-list id "ひらがな")
    (im-pushback-mode-list id "カタカナ")
    (im-pushback-mode-list id "全角英数")
    (im-pushback-mode-list id "半角カタカナ")
    (im-update-mode-list id)
    (im-update-mode id 0)
    (canna-update-prop-list id)
    ()))

(define (canna-release-handler id)
  (let* ((c (find-context id))
	 (cc (context-data c))
	 (cc-id (canna-context-cc-id cc)))
    (canna-lib-release-context cc-id)))

(define (canna-mode-handler id mode)
  (let* ((c (find-context id))
	 (cc (context-data c)))
    (canna-flush cc)
    (cond  ; `case' is not supported by uim
     ((= mode multi-segment-mode-direct)  ; 'direct'
      (canna-context-set-on! cc #f)
      (canna-context-set-wide-latin! cc #f))
     ((= mode multi-segment-mode-hiragana)  ; 'hiragana'
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-hiragana))
     ((= mode multi-segment-mode-katakana)  ; 'katakana'
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-katakana))
     ((= mode multi-segment-mode-wide-latin)  ; 'wide-latin'
      (canna-context-set-on! cc #f)
      (canna-context-set-wide-latin! cc #t))
     ((= mode multi-segment-mode-hankana)
      (canna-context-set-on! cc #t)
      (canna-context-set-kana-mode! cc multi-segment-type-hankana)))  
    (canna-update-preedit cc id))
  ())

(define (canna-move-segment cc dir)
  (let ((pos (+ (canna-context-cur-seg cc) dir))
	(nseg (length (canna-context-index-list cc))))
      (if (and
	   (> pos -1)
	   (< pos nseg))
	  (canna-context-set-cur-seg! cc pos))))

(define (canna-move-candidate cc id off)
  (let* ((seg (canna-context-cur-seg cc))
	 (n (nth seg (canna-context-index-list cc)))
	 (cc-id (canna-context-cc-id cc))
	 (max (canna-lib-get-nr-candidates cc-id seg)))
    (set! n (+ n off))
    (if (>= n max)
	(set! n 0))
    (if (< n 0)
	(set! n (- max 1)))
    (set-car! (nthcdr seg (canna-context-index-list cc)) n)
    (canna-context-set-candidate-op-count!
     cc
     (+ 1 (canna-context-candidate-op-count cc)))
    (if (and
	 (= (canna-context-candidate-op-count cc)
	    canna-candidate-op-count)
	 canna-use-candidate-window?)
	(begin
	  (canna-context-set-candidate-window! cc #t)
	  (im-activate-candidate-selector
	   id
	   max canna-nr-candidate-max)))
    (if (canna-context-candidate-window cc)
	(im-select-candidate id n))))

(define (canna-reset-candidate-window cc id)
  (if (canna-context-candidate-window cc)
      (begin
	(im-deactivate-candidate-selector id cc)
	(canna-context-set-candidate-window! cc #f)))
  (canna-context-set-candidate-op-count! cc 0))

(define (canna-resize-segment cc id cnt)
  (let
      ((cc-id (canna-context-cc-id cc)))
      (canna-reset-candidate-window cc id)
      (canna-lib-resize-segment
       cc-id (canna-context-cur-seg cc) cnt)
      (canna-context-set-index-list!
       cc
       (multi-segment-make-index-list
	(canna-lib-get-nr-segments cc-id)
	(truncate-list
	 (canna-context-index-list cc)
	 (canna-context-cur-seg cc)))
      )))

(define (canna-proc-compose-state cc id key key-state)
  (let
      ((cc-id (canna-context-cc-id cc)))
    (cond
     ((canna-commit-key? key key-state)
      (canna-do-commit cc id))

     ((canna-extend-segment-key? key key-state)
      (canna-resize-segment cc id 1))

     ((canna-shrink-segment-key? key key-state)
      (canna-resize-segment cc id -1))

     ((canna-next-segment-key? key key-state)
      (begin
	(canna-move-segment cc 1)
	(canna-reset-candidate-window cc id)))

     ((canna-prev-segment-key? key key-state)
      (begin
	(canna-move-segment cc -1)
	(canna-reset-candidate-window cc id)))

     ((canna-backspace-key? key key-state)
      (begin
	(canna-context-set-state! cc #f)
	(canna-reset-candidate-window cc id)))

     ((canna-next-candidate-key? key key-state)
      (canna-move-candidate cc id 1))

     ((canna-prev-candidate-key? key key-state)
      (canna-move-candidate cc id -1))

     ((canna-cancel-key? key key-state)
      (begin
	(canna-context-set-state! cc #f)
	(canna-reset-candidate-window cc id)
	(canna-lib-reset-conversion cc-id)))

     ((and (modifier-key-mask key-state)
	   (not (shift-key-mask key-state)))
      #f)

     ((symbol? key)
      #f)

     (else
      (begin
	(canna-do-commit cc id)
	(canna-proc-input-state cc id key key-state))))))

(define (canna-proc-wide-latin c key key-state)
  (let* ((char (charcode->string key))
	 (w (or (ja-direct char)
		(ja-wide char)))
	 (id (context-id c))
	 (cc (context-data c)))
    (cond
     ((canna-on-key? key key-state)
      (canna-flush cc)
      (canna-update-mode cc id)
      (canna-update-prop-label cc id))
     ((and (modifier-key-mask key-state)
	   (not (shift-key-mask key-state)))
      (canna-commit-raw id))
     (w
      (im-commit id w))
     (else
      (im-commit-raw id)))
    ()))

(define (canna-press-key-handler id key key-state)
  (let* ((c (find-context id))
	 (cc (context-data c)))
    (if (control-char? key)
	(im-commit-raw id)
	(if (canna-context-on cc)
	    (if (canna-context-state cc)
		(canna-proc-compose-state cc id key key-state)
		(canna-proc-input-state cc id key key-state))
	    (if (canna-context-wide-latin cc)
		(canna-proc-wide-latin c key key-state)
		(canna-proc-raw-state c key key-state))))
    (canna-update-preedit cc id)))

;;;
(define (canna-release-key-handler id key key-state)
  (let* ((c (find-context id))
	 (cc (context-data c)))
    (if (or (control-char? key)
	    (and
	     (not (canna-context-on cc))
	     (not (canna-context-wide-latin cc))))
	(canna-commit-raw cc id))))
;;;
(define (canna-reset-handler id)
  (let* ((c (find-context id))
	 (cc (context-data c))
	 (cc-id (canna-context-cc-id cc)))
    (canna-lib-reset-conversion cc-id)))

;;;
(define (canna-get-candidate-handler id idx accel-enum-hint)
  (let* ((c (find-context id))
	 (cc (context-data c))
	 (cc-id (canna-context-cc-id cc))
	 (cand (canna-lib-get-nth-candidate
		cc-id (canna-context-cur-seg cc) idx)))
    (list cand (digit->string (+ idx 1)))))

(define (canna-set-candidate-index-handler id idx)
  (let* ((c (find-context id))
	 (cc (context-data c))
	 (seg (canna-context-cur-seg cc))
	 (cc-id (canna-context-cc-id cc)))
    (set-car! (nthcdr seg (canna-context-index-list cc)) idx)
    (canna-update-preedit cc id)))

;;;

(define (canna-prop-handler id message)
  (let* ((c (find-context id))
	 (cc (context-data c)))
    (canna-flush cc)
    (canna-update-preedit cc id)
    (cond
     ((string=? message
		     "prop_canna_hiragana")
      (begin
	(canna-context-set-on! cc #t)
	(canna-context-set-kana-mode! cc multi-segment-type-hiragana)))
     ((string=? message
		     "prop_canna_katakana")
      (begin
	(canna-context-set-on! cc #t)
	(canna-context-set-kana-mode! cc multi-segment-type-katakana)))
     ((string=? message
		     "prop_canna_hankana")
      (begin
	(canna-context-set-on! cc #t)
	(canna-context-set-kana-mode! cc multi-segment-type-hankana)))
     ((string=? message
		     "prop_canna_direct")
	(begin
	  (canna-context-set-on! cc #f)
	  (canna-context-set-wide-latin! cc #f)))
     ((string=? message
		     "prop_canna_zenkaku")
      (begin
	(canna-context-set-on! cc #f)
	(canna-context-set-wide-latin! cc #t)))
     ((string=? message
		     "prop_canna_kana")
      (begin
	(load-kana-table))))
    (canna-update-mode cc id)
    (canna-update-prop-label cc id)))
;;;

(define (canna-proc-raw-state c key key-state)
    (let ((id (context-id c))
	  (cc (context-data c)))
      (if (canna-on-key? key key-state)
	  (begin
	    (canna-begin-input cc)
	    (canna-update-mode cc id)
	    (canna-update-prop-label cc id))
	  (im-commit-raw (context-id c))
	  (canna-update-preedit)
)))

(define (canna-update-prop-label cc id)
  (let ((str "")
	(kana (canna-context-kana-mode cc)))
    (set! str
	  (if (canna-context-on cc)
	      (cond
	       ((= kana multi-segment-type-hiragana)
		"あ\tひらがな\n")
	       ((= kana multi-segment-type-katakana)
		"ア\tカタカナ\n")
	       ((= kana multi-segment-type-hankana)
		"ｱ\t半角カタカナ\n"))
	      (if (canna-context-wide-latin cc)
		  "ａ\t全角英数\n"
		  "a\t直接入力\n")))
    (set! str (string-append str "Ｒ\t入力モード\n"))
    (im-update-prop-label id str)))

(define (canna-update-mode cc id)
  (if (canna-context-on cc)
      (let ((kana (canna-context-kana-mode cc)))
	(cond
	 ((= kana multi-segment-type-hiragana)
	  (im-update-mode id multi-segment-mode-hiragana))
	 ((= kana multi-segment-type-katakana)
	  (im-update-mode id multi-segment-mode-katakana))
	 ((= kana multi-segment-type-hankana)
	  (im-update-mode id multi-segment-mode-hankana))))
      (if (canna-context-wide-latin cc)
	  (im-update-mode id multi-segment-mode-wide-latin)
	  (im-update-mode id multi-segment-mode-direct)))
  (canna-update-prop-label cc id))

(define (canna-update-prop-list id)
  (let* ((c (find-context id))
	 (cc (context-data c))
	 (str "branch\t"))
    (set! str
	  (string-append str
			 (if (canna-context-on cc)
			     "あ\tひらがな\n"
			     (if (canna-context-wide-latin cc)
				 "ａ\t全角英数\n"
				 "a\t直接入力\n"))))
    (set! str
	  (string-append
	   str
	   "leaf\tあ\tひらがな\tひらがなです\tprop_canna_hiragana\n"
	   "leaf\tア\tカタカナ\tカタカナで入力できます\tprop_canna_katakana\n"
	   "leaf\tｱ\t半角カタカナ\t半角カタカナで入力できます\tprop_canna_hankana\n"
	   "leaf\tA\t直接入力\tダイレクトです\tprop_canna_direct\n"
	   "leaf\tａ\t全角英数\t全角英数モード\tprop_canna_zenkaku\n"
	   "branch\tＲ\t入力方式\nleaf\tＲ\tローマ字\tdesc\tprop_canna_roma\n"
	   "leaf\tか\tかな\tかな入力\tdescription\tprop_canna_kana\n"))
    (im-update-prop-list id str)))

(define canna-prop-list
  '(
    ("branch" "入力状態")
    ("leaf" "あ" "ひらがな" "ひらがなで入力できます" "prop_canna_hiragana")
    ("leaf" "ア" "カタカナ" "カタカナ" "prop_canna_katakana")
    ("leaf" "ａ" "全角英数" "全角英数モード" "prop_canna_zenkaku")
    ("leaf" "a" "直接入力" "アルファベットが入力できます" "prop_canna_direct")
    ("branch" "入力モード")
    ("leaf" "Ｒ" "ローマ字" "ローマ字入力" "prop_canna_roma")
    ("leaf" "か" "かな" "かな入力" "prop_canna_kana")))

(if (and
     (symbol-bound? 'canna-lib-init)
     (canna-lib-init canna-server-name))
    (set! canna-init-lib-ok? #t))

(if (and
     (symbol-bound? 'canna-lib-init)
     (= canna-init-lib-ok? #t))
    (register-im
     'canna
     "ja"
    "EUC-JP"
     #f
     canna-init-handler
     canna-release-handler
     canna-mode-handler
     canna-press-key-handler
     canna-release-key-handler
     canna-reset-handler
     canna-get-candidate-handler
     canna-set-candidate-index-handler
     canna-prop-handler))
