[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Wed Apr 30 21:27:48 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv7853
Modified Files:
mcclim.asd stream-input.lisp
Added Files:
dead-keys.lisp
Log Message:
Really Fix dead keys.
Now integrated with the gesture reading machinery in
standard-extended-input-steeam, so it can be circumvented if you
really don't want it by handling events manually.
--- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/29 16:27:42 1.81
+++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/30 21:27:48 1.82
@@ -164,6 +164,7 @@
"stream-output" "recording"))
(:file "stream-input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "input" "ports" "sheets" "events"
"encapsulate" "transforms" "utils"))
+ (:file "dead-keys" :depends-on ("stream-input"))
(:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output"
"transforms" "sheets" "stream-output"
"ports" "recording" "regions"
@@ -259,8 +260,7 @@
:components ((:file "packages")
(:file "utils" :depends-on ("packages"))
(:file "colors" :depends-on ("packages"))
- (:file "dead-keys" :depends-on ("utils"))
- (:file "esa" :depends-on ("colors" "packages" "utils" "dead-keys"))
+ (:file "esa" :depends-on ("colors" "packages" "utils"))
(:file "esa-buffer" :depends-on ("packages" "esa"))
(:file "esa-io" :depends-on ("packages" "esa" "esa-buffer"))
(:file "esa-command-parser" :depends-on ("packages" "esa"))))))
--- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2007/02/07 12:44:17 1.51
+++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/04/30 21:27:48 1.52
@@ -122,9 +122,77 @@
do (handle-event (event-sheet event) event))
nil)
+(defvar *dead-key-table* (make-hash-table :test 'equal)
+ "A hash table mapping keyboard event names and characters to
+either a similar hash table or characters.")
+
+(defclass dead-key-merging-mixin ()
+ ((state :initform *dead-key-table*)
+ (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream
+ (last-state))
+ (:documentation "A mixin class for extended input streams that
+takes care of handling dead keys. This is done by still passing
+every gesture on, but accenting the final one as per the dead
+keys read."))
+
+(defmethod stream-read-gesture :around
+ ((stream dead-key-merging-mixin)
+ &key timeout peek-p
+ (input-wait-test *input-wait-test*)
+ (input-wait-handler *input-wait-handler*)
+ (pointer-button-press-handler
+ *pointer-button-press-handler*))
+ (with-slots (state last-deadie-gesture last-state) stream
+ (handler-case
+ (loop with start-time = (get-internal-real-time)
+ with end-time = start-time
+ for gesture = (call-next-method stream
+ :timeout (when timeout
+ (- timeout (/ (- end-time start-time)
+ internal-time-units-per-second)))
+ :peek-p peek-p
+ :input-wait-test input-wait-test
+ :input-wait-handler input-wait-handler
+ :pointer-button-press-handler
+ pointer-button-press-handler)
+ do (setf end-time (get-internal-real-time)
+ last-deadie-gesture gesture
+ last-state state)
+ do (if (typep gesture '(or keyboard-event character))
+ (let ((value (gethash (if (characterp gesture)
+ gesture
+ (keyboard-event-key-name gesture))
+ state)))
+ (etypecase value
+ (null
+ (cond ((eq state *dead-key-table*)
+ (return gesture))
+ ((or (and (typep gesture 'keyboard-event)
+ (keyboard-event-character gesture))
+ (characterp gesture))
+ (setf state *dead-key-table*))))
+ (character
+ (setf state *dead-key-table*)
+ (return value))
+ (hash-table
+ (return (setf state value)))))
+ (return gesture)))
+ ;; Policy decision: an abort cancels the current composition.
+ (abort-gesture (c)
+ (setf state *dead-key-table*)
+ (signal c)))))
+
+(defmethod stream-unread-gesture :around ((stream dead-key-merging-mixin) gesture)
+ (if (typep gesture '(or keyboard-event character))
+ (with-slots (state last-deadie-gesture last-state) stream
+ (setf state last-state)
+ (call-next-method stream last-deadie-gesture))
+ (call-next-method)))
+
(defclass standard-extended-input-stream (extended-input-stream
;; FIXME: is this still needed?
- standard-sheet-input-mixin)
+ standard-sheet-input-mixin
+ dead-key-merging-mixin)
((pointer)
(cursor :initarg :text-cursor)
(last-gesture :accessor last-gesture :initform nil
--- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 NONE
+++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 1.1
;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
;;; (c) copyright 2008 by
;;; Troels Henriksen (athas at sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Define various dead keys - perhaps this should be more
;;; backend-agnostic? Bah...
(in-package :clim-internals)
(defun set-dead-key-combination (character gestures table)
"Set `gestures' to result in `character' in the hash table
`table' (see `*dead-key-table*' for the format of the hash
table)."
(assert (not (null gestures)))
(if (null (rest gestures))
;; Just add it directly to this table.
(setf (gethash (first gestures) table) character)
;; Ensure that the subtable exists.
(let ((new-table (setf (gethash (first gestures) table)
(gethash (first gestures) table
(make-hash-table :test 'equal)))))
(set-dead-key-combination character (rest gestures) new-table))))
(defmacro define-dead-key-combination (character (&rest gestures))
"Define a dead key combination that results in `character' when
`gestures' (either characters or key names) is entered."
(assert (>= (length gestures) 2))
`(set-dead-key-combination ,character ',gestures *dead-key-table*))
(define-dead-key-combination (code-char 193) (:dead-acute #\a))
(define-dead-key-combination (code-char 201) (:dead-acute #\e))
(define-dead-key-combination (code-char 205) (:dead-acute #\i))
(define-dead-key-combination (code-char 211) (:dead-acute #\o))
(define-dead-key-combination (code-char 218) (:dead-acute #\u))
(define-dead-key-combination (code-char 221) (:dead-acute #\y))
(define-dead-key-combination (code-char 225) (:dead-acute #\a))
(define-dead-key-combination (code-char 233) (:dead-acute #\e))
(define-dead-key-combination (code-char 237) (:dead-acute #\i))
(define-dead-key-combination (code-char 243) (:dead-acute #\o))
(define-dead-key-combination (code-char 250) (:dead-acute #\u))
(define-dead-key-combination (code-char 253) (:dead-acute #\y))
(define-dead-key-combination (code-char 199) (:dead-acute #\c))
(define-dead-key-combination (code-char 231) (:dead-acute #\c))
(define-dead-key-combination (code-char 215) (:dead-acute #\x))
(define-dead-key-combination (code-char 247) (:dead-acute #\-))
(define-dead-key-combination (code-char 222) (:dead-acute #\t))
(define-dead-key-combination (code-char 254) (:dead-acute #\t))
(define-dead-key-combination (code-char 223) (:dead-acute #\s))
(define-dead-key-combination (code-char 39) (:dead-acute #\space))
(define-dead-key-combination (code-char 197) (:dead-acute :dead-acute #\a))
(define-dead-key-combination (code-char 229) (:dead-acute :dead-acute #\a))
(define-dead-key-combination (code-char 192) (:dead-grave #\a))
(define-dead-key-combination (code-char 200) (:dead-grave #\e))
(define-dead-key-combination (code-char 204) (:dead-grave #\i))
(define-dead-key-combination (code-char 210) (:dead-grave #\o))
(define-dead-key-combination (code-char 217) (:dead-grave #\u))
(define-dead-key-combination (code-char 224) (:dead-grave #\a))
(define-dead-key-combination (code-char 232) (:dead-grave #\e))
(define-dead-key-combination (code-char 236) (:dead-grave #\i))
(define-dead-key-combination (code-char 242) (:dead-grave #\o))
(define-dead-key-combination (code-char 249) (:dead-grave #\u))
(define-dead-key-combination (code-char 96) (:dead-grave #\space))
(define-dead-key-combination (code-char 96) (:dead-grave :dead-grave))
(define-dead-key-combination (code-char 196) (:dead-diaeresis #\a))
(define-dead-key-combination (code-char 203) (:dead-diaeresis #\e))
(define-dead-key-combination (code-char 207) (:dead-diaeresis #\i))
(define-dead-key-combination (code-char 214) (:dead-diaeresis #\o))
(define-dead-key-combination (code-char 220) (:dead-diaeresis #\u))
(define-dead-key-combination (code-char 228) (:dead-diaeresis #\a))
(define-dead-key-combination (code-char 235) (:dead-diaeresis #\e))
(define-dead-key-combination (code-char 239) (:dead-diaeresis #\i))
(define-dead-key-combination (code-char 246) (:dead-diaeresis #\o))
(define-dead-key-combination (code-char 252) (:dead-diaeresis #\u))
(define-dead-key-combination (code-char 255) (:dead-diaeresis #\y))
(define-dead-key-combination (code-char 168) (:dead-diaeresis #\space))
(define-dead-key-combination (code-char 168) (:dead-diaeresis :dead-diaeresis))
(define-dead-key-combination (code-char 195) (:dead-tilde #\a))
(define-dead-key-combination (code-char 209) (:dead-tilde #\n))
(define-dead-key-combination (code-char 227) (:dead-tilde #\a))
(define-dead-key-combination (code-char 241) (:dead-tilde #\n))
(define-dead-key-combination (code-char 198) (:dead-tilde #\e))
(define-dead-key-combination (code-char 230) (:dead-tilde #\e))
(define-dead-key-combination (code-char 208) (:dead-tilde #\d))
(define-dead-key-combination (code-char 240) (:dead-tilde #\d))
(define-dead-key-combination (code-char 245) (:dead-tilde #\o))
(define-dead-key-combination (code-char 126) (:dead-tilde #\space))
(define-dead-key-combination (code-char 126) (:dead-tilde :dead-tilde))
(define-dead-key-combination (code-char 194) (:dead-circumflex #\a))
(define-dead-key-combination (code-char 202) (:dead-circumflex #\e))
(define-dead-key-combination (code-char 206) (:dead-circumflex #\i))
(define-dead-key-combination (code-char 212) (:dead-circumflex #\o))
(define-dead-key-combination (code-char 219) (:dead-circumflex #\u))
(define-dead-key-combination (code-char 226) (:dead-circumflex #\a))
(define-dead-key-combination (code-char 234) (:dead-circumflex #\e))
(define-dead-key-combination (code-char 238) (:dead-circumflex #\i))
(define-dead-key-combination (code-char 244) (:dead-circumflex #\o))
(define-dead-key-combination (code-char 251) (:dead-circumflex #\u))
(define-dead-key-combination (code-char 94) (:dead-circumflex #\space))
(define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex))
More information about the Mcclim-cvs
mailing list