1;;;
2;;; Copyright (c) 2003-2013 uim Project https://github.com/uim/uim
3;;;
4;;; All rights reserved.
5;;;
6;;; Redistribution and use in source and binary forms, with or without
7;;; modification, are permitted provided that the following conditions
8;;; are met:
9;;; 1. Redistributions of source code must retain the above copyright
10;;;    notice, this list of conditions and the following disclaimer.
11;;; 2. Redistributions in binary form must reproduce the above copyright
12;;;    notice, this list of conditions and the following disclaimer in the
13;;;    documentation and/or other materials provided with the distribution.
14;;; 3. Neither the name of authors nor the names of its contributors
15;;;    may be used to endorse or promote products derived from this software
16;;;    without specific prior written permission.
17;;;
18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
19;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
22;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
24;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
25;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28;;; SUCH DAMAGE.
29;;;;
30
31(require "generic.scm")
32
33;; Hangul IMs requires some generic-keys disabled. See the post "A
34;; question about the space bar" in uim@pdx.freedesktop.org
35;; mailinglist from David Oftedal at Fri, 02 Apr 2004 22:55:25 +0200
36(define hangul-proc-on-mode-with-preedit
37  (let* ((non-existent-key? (make-single-key-predicate ""))
38	 (generic-next-candidate-key? non-existent-key?)
39	 (generic-prev-candidate-key? non-existent-key?)
40	 (generic-commit-key? non-existent-key?)
41	 (generic-proc-input-state-with-preedit-with-this-env
42	  (%%enclose-another-env generic-proc-input-state-with-preedit
43				 (%%current-environment))))
44    (lambda (gc key state rkc)  ;; "gc" stands for "generic-context"
45      (generic-proc-input-state-with-preedit-with-this-env gc key state rkc))))
46
47(define hangul-proc-on-mode
48  (let* ((non-existent-key? (make-single-key-predicate ""))
49	 (generic-next-candidate-key? non-existent-key?)
50	 (generic-prev-candidate-key? non-existent-key?)
51	 (generic-commit-key? non-existent-key?)
52	 (generic-proc-input-state-with-preedit
53	  hangul-proc-on-mode-with-preedit)
54	 (generic-proc-input-state-with-this-env
55	  (%%enclose-another-env generic-proc-input-state (%%current-environment))))
56    (lambda (gc key state)  ;; "gc" stands for "generic-context"
57      (generic-proc-input-state-with-this-env gc key state))))
58
59;; 'let*' is required rather than 'let'
60(define hangul-key-press-handler
61  (let* ((generic-proc-input-state hangul-proc-on-mode)
62	 (generic-key-press-handler-with-this-env
63	  (%%enclose-another-env generic-key-press-handler (%%current-environment))))
64    (lambda (gc key state)
65      (generic-key-press-handler-with-this-env gc key state))))
66
67(define hangul-register-im
68  (lambda (name lang code name-label short-desc init-arg)
69    (register-im
70     name
71     lang
72     code
73     name-label
74     short-desc
75     init-arg
76     generic-init-handler
77     #f ;; release-handler
78     context-mode-handler
79     hangul-key-press-handler
80     generic-key-release-handler
81     generic-reset-handler
82     generic-get-candidate-handler
83     generic-set-candidate-index-handler
84     context-prop-activate-handler
85     #f
86     generic-focus-in-handler
87     generic-focus-out-handler
88     generic-place-handler
89     generic-displace-handler
90     )))
91
92(define hangul2-init-handler
93  (lambda (id im arg)
94    (require "hangul2.scm")
95    (generic-context-new id im hangul2-rule #t)))
96
97(define hangul3-init-handler
98  (lambda (id im arg)
99    (require "hangul3.scm")
100    (generic-context-new id im hangul3-rule #t)))
101
102(define romaja-init-handler
103  (lambda (id im arg)
104    (require "romaja.scm")
105    (generic-context-new id im romaja-rule #t)))
106
107(hangul-register-im
108 'hangul2
109 "ko"
110 "UTF-8"
111 (N_ "Hangul (2-beol)")
112 (N_ "2-beol style hangul input method")
113 hangul2-init-handler)
114
115;; hangul3 IM does not require generic-keys disabled
116(generic-register-im
117 'hangul3
118 "ko"
119 "UTF-8"
120 (N_ "Hangul (3-beol)")
121 (N_ "3-beol style hangul input method")
122 hangul3-init-handler)
123
124(hangul-register-im
125 'romaja
126 "ko"
127 "UTF-8"
128 (N_ "Hangul (Romaja)")
129 (N_ "Romaja input style hangul input method")
130 romaja-init-handler)
131