[uim-commit] r190 - in trunk: scm uim
yamaken@freedesktop.org
yamaken@freedesktop.org
Sun Jan 9 07:01:48 PST 2005
Author: yamaken
Date: 2005-01-09 07:01:17 -0800 (Sun, 09 Jan 2005)
New Revision: 190
Modified:
trunk/scm/custom.scm
trunk/uim/uim-custom.c
Log:
* This commit adds new custom type 'key'. All functions are
validated and available for use in Scheme level. Using via
uim-custom.h is not checked yet
* scm/custom.scm
- (custom-key?): Implement
- (custom-expand-key-references, custom-exist?,
custom-list-as-literal): New procedure
- (define-custom): Add custom-set-value! invocation to apply special
handlings such as define-key
- (custom-set-value!): Invoke define-key if custom type is key
- (custom-value-as-literal):
* Simplify with custom-list-as-literal
* Support custom type 'key'
- (custom-definition-as-literal): Put define-key if custom type is
'key'
* uim/uim-custom.c
- (uim_custom_key_get): Modify sexp to get value
Modified: trunk/scm/custom.scm
===================================================================
--- trunk/scm/custom.scm 2005-01-09 14:47:21 UTC (rev 189)
+++ trunk/scm/custom.scm 2005-01-09 15:01:17 UTC (rev 190)
@@ -35,6 +35,7 @@
(require "i18n.scm")
(require "util.scm")
+(require "key.scm")
;; private
(define custom-rec-alist ())
@@ -95,6 +96,28 @@
(apply custom-valid-choice? (cons sym choice-rec-alist)))
syms)))))
+(define custom-key?
+ (lambda (key-repls)
+ (and (list? key-repls)
+ (every (lambda (key)
+ (or (string? key) ;; "<Control>a"
+ (and (symbol? key) ;; 'generic-cancel-key
+ (custom-exist? key 'key))))
+ key-repls))))
+
+(define custom-expand-key-references
+ (lambda (key)
+ (cond
+ ((string? key)
+ (list key))
+ ((list? key)
+ (apply append (map custom-expand-key-references key)))
+ ((and (symbol? key)
+ (custom-exist? key 'key))
+ (custom-expand-key-references (custom-value key)))
+ (else
+ ()))))
+
(define-record 'custom-choice-rec
'((sym #f)
(label "")
@@ -114,10 +137,6 @@
(desc (custom-choice-rec-desc srec)))
desc)))
-(define custom-key?
- (lambda (def)
- ))
-
(define-record 'custom-group-rec
'((sym #f)
(label "")
@@ -245,7 +264,8 @@
(list 'quote default)
default)))
(eval (list 'define sym default)
- toplevel-env)))
+ toplevel-env)
+ (custom-set-value! sym default))) ;; to apply hooks
(for-each (lambda (subgrp)
(let ((registered (custom-group-subgroups primary-grp)))
(if (not (memq subgrp registered))
@@ -254,6 +274,14 @@
custom-subgroup-alist)))))
subgrps))))
+;; #f as type means 'any type'
+(define custom-exist?
+ (lambda (sym type)
+ (and (assq sym custom-rec-alist)
+ (or (not type)
+ (eq? type
+ (custom-type sym))))))
+
;; API
(define custom-valid?
(lambda (sym val)
@@ -279,6 +307,9 @@
(let* ((custom-syms (custom-collect-by-group #f))
(pre-activities (map custom-active? custom-syms)))
(set-symbol-value! sym val)
+ (if (eq? (custom-type sym)
+ 'key)
+ (define-key (symbolconc sym '?) val))
(custom-call-hook-procs sym custom-set-hooks)
(let ((post-activities (map custom-active? custom-syms)))
(for-each (lambda (another-sym pre post)
@@ -348,16 +379,31 @@
(lambda (sym)
(custom-rec-desc (custom-rec sym))))
+(define custom-list-as-literal
+ (lambda (lst)
+ (let* ((padded-list (map (lambda (elem)
+ (list " "
+ (cond
+ ((symbol? elem)
+ (symbol->string elem))
+ ((string? elem)
+ (string-append "\"" elem "\""))
+ (else
+ ""))))
+ lst))
+ (literalized (if (null? padded-list)
+ ""
+ (apply string-append
+ (cdr (apply append padded-list))))))
+ (string-append "'(" literalized ")"))))
+
;; API
(define custom-value-as-literal
(lambda (sym)
(let ((val (custom-value sym))
(type (custom-type sym))
(as-string (lambda (s)
- (string-append
- "\""
- s
- "\""))))
+ (string-append "\"" s "\""))))
(cond
((or (eq? val #f)
(eq? type 'boolean))
@@ -372,17 +418,9 @@
(as-string val))
((eq? type 'choice)
(string-append "'" (symbol->string val)))
- ((eq? type 'ordered-list)
- (let* ((padded-list (map (lambda (item)
- (list " " (symbol->string item)))
- val))
- (literalized (if (null? padded-list)
- ""
- (apply string-append
- (cdr (apply append padded-list))))))
- (string-append "'(" literalized ")")))
- ((eq? type 'key)
- ""))))) ;; TODO
+ ((or (eq? type 'ordered-list)
+ (eq? type 'key))
+ (custom-list-as-literal val))))))
;; Don't invoke this from a literalize-hook. It will cause infinite loop
(define custom-definition-as-literal
@@ -392,8 +430,13 @@
(hooked (custom-call-hook-procs sym custom-literalize-hooks)))
(if (not (null? hooked))
(apply string-append hooked)
- (string-append
- "(define " var " " val ")")))))
+ (apply string-append
+ (append
+ (list "(define " var " " val ")")
+ (if (eq? (custom-type sym)
+ 'key)
+ (list "\n(define-key " var "? " val ")")
+ ())))))))
;; API
;; TODO: implement after uim 0.4.6 depending on scm-nested-eval
Modified: trunk/uim/uim-custom.c
===================================================================
--- trunk/uim/uim-custom.c 2005-01-09 14:47:21 UTC (rev 189)
+++ trunk/uim/uim-custom.c 2005-01-09 15:01:17 UTC (rev 190)
@@ -335,7 +335,7 @@
int *key_type_list, editor_type, list_len, i;
struct uim_custom_key *custom_key, **custom_key_list;
- UIM_EVAL_FSTRING3(NULL, "(define %s (custom-expand-key-references '%s (custom-range '%s))",
+ UIM_EVAL_FSTRING3(NULL, "(define %s (apply (if uim-custom-expand-key? custom-expand-key-references list) (custom-value '%s))",
str_list_arg, custom_sym, custom_sym);
key_literal_list =
(char **)uim_scm_c_list(str_list_arg,
@@ -639,6 +639,9 @@
uim_scm_require_file("custom.scm");
+ /* temporary solution to control key definition expantion */
+ UIM_EVAL_STRING(NULL, "(define uim-custom-expand-key? #t)");
+
return UIM_TRUE;
}
More information about the Uim-commit
mailing list