File: modifier-list.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (73 lines) | stat: -rw-r--r-- 2,077 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
#| modifier-list.jl -- widget for a list of modifier keys

   $Id: modifier-list.jl,v 1.2 2000/12/18 21:37:18 jsh Exp $

   Author: John Harper <john@dcs.warwick.ac.uk>

   Copyright (C) 2000 Eazel, Inc.

   This file is part of sawfish.

   sawfish is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2, or (at your option)
   any later version.

   sawfish 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 General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with sawfish; see the file COPYING.  If not, write to
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#

(define-structure sawfish.ui.widgets.modifier-list ()

    (open rep
	  rep.regexp
	  sawfish.gtk.widget)

  ;; XXX should read the non-null modifiers from the wm?

  (define modifiers '(shift control meta alt hyper super))

  (define (list->symbol x)
    (if (null x)
	nil
      (intern (mapconcat symbol-name x #\space))))

  (define (symbol->list x)
    (if (not x)
	'()
      (mapcar (lambda (x)
		(intern (string-downcase x)))
	      (string-split "[-,; \t]" (symbol-name x)))))

  (define (validp x)
    (and (listp x)
	 (not (null x))
	 (let loop ((rest x))
	   (cond ((null rest) t)
		 ((not (memq (car rest) modifiers)) nil)
		 (t (loop (cdr rest)))))))

  (define (make-item changed-callback)
    (let (base)

      (define (real-changed)
	(let ((value (widget-ref base)))
	  (when (validp (symbol->list value))
	    (changed-callback))))

      (setq base (make-widget `(symbol ,@modifiers) real-changed))

      (lambda (op)
	(case op
	  ((set) (lambda (x) (widget-set base (list->symbol x))))
	  ((ref) (lambda () (symbol->list (widget-ref base))))
	  ((validp) validp)
	  (t (base op))))))

  (define-widget-type 'modifier-list make-item))