← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/kernel/texmacs/tm-preferences.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/kernel/texmacs/tm-preferences.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : tm-preferences.scm
 
5
;; DESCRIPTION : management of the user preferences
 
6
;; COPYRIGHT   : (C) 1999  Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (kernel texmacs tm-preferences)
 
16
  (:use (kernel texmacs tm-define))
 
17
  (:export
 
18
    preferences-initialization-flag
 
19
    preferences-table preferences-call-back ;; for define-preferences macro
 
20
    define-preferences
 
21
    set-preference get-preference toggle-preference
 
22
    notify-preference retrieve-preferences apply-preferences))
 
23
 
 
24
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
25
;; Defining preference call back routines
 
26
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
27
 
 
28
(define preferences-initialization-flag #f)
 
29
(define preferences-table (make-ahash-table))
 
30
(define preferences-call-back (make-ahash-table))
 
31
 
 
32
(define (define-preference x)
 
33
  (with (which value call-back) x
 
34
    `(if (not (ahash-ref preferences-table ,which))
 
35
         (ahash-set! preferences-table ,which ,value))))
 
36
 
 
37
(define (define-preference-call-back x)
 
38
  (with (which value call-back) x
 
39
    `(begin
 
40
       (ahash-set! preferences-call-back ,which ,call-back)
 
41
       (if preferences-initialization-flag (notify-preference ,which)))))
 
42
 
 
43
(define-macro (define-preferences . l)
 
44
  (append '(begin)
 
45
          (map-in-order define-preference l)
 
46
          (map-in-order define-preference-call-back l)))
 
47
 
 
48
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
49
;; Setting and getting preferences
 
50
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
51
 
 
52
(define (test-preference? which what)
 
53
  (== what (get-preference which)))
 
54
 
 
55
(tm-define (set-preference which what)
 
56
  (:check-mark "*" test-preference?)
 
57
  (ahash-set! preferences-table which what)
 
58
  ;(display* "set-preference " which " := " what "\n")
 
59
  ((get-call-back which) which what)
 
60
  (save-preferences))
 
61
 
 
62
(define (get-preference which)
 
63
  (ahash-ref preferences-table which))
 
64
 
 
65
(define (preference-on? which)
 
66
  (test-preference? which "on"))
 
67
 
 
68
(tm-define (toggle-preference which)
 
69
  (:check-mark "v" preference-on?)
 
70
  (let ((what (get-preference which)))
 
71
    (set-preference which (cond ((== what "on") "off")
 
72
                                ((== what "off") "on")
 
73
                                (else what)))))
 
74
 
 
75
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
76
;; Applying preferences
 
77
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
78
 
 
79
(define (get-call-back what)
 
80
  (let ((r (ahash-ref preferences-call-back what)))
 
81
    (if r r (lambda args (noop)))))
 
82
 
 
83
(define (notify-preference var)
 
84
  ;(display* "notify-preference " var "\n")
 
85
  ((get-call-back var) var (get-preference var)))
 
86
 
 
87
(define (preference-apply l)
 
88
  ;(display* "preference-apply " l "\n")
 
89
  ((get-call-back (car l)) (car l) (cadr l)))
 
90
 
 
91
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
92
;; Initialize preferences and consulting preferences
 
93
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
94
 
 
95
(define user-preferences '())
 
96
(define saved-preferences '())
 
97
 
 
98
(define (preferences->list table)
 
99
  (let* ((folder (lambda (key im tail) (cons (list key im) tail)))
 
100
         (unsorted (ahash-fold folder '() table))
 
101
         (comp? (lambda (l1 l2) (string<=? (car l1) (car l2)))))
 
102
    (list-sort unsorted comp?)))
 
103
 
 
104
(define (save-preferences)
 
105
  (set! user-preferences (preferences->list preferences-table))
 
106
  (if (not (== user-preferences saved-preferences))
 
107
      (begin
 
108
        (save-object "$TEXMACS_HOME_PATH/system/preferences.scm"
 
109
                     user-preferences)
 
110
        (set! saved-preferences user-preferences))))
 
111
 
 
112
(define (retrieve-preferences)
 
113
  (if (url-exists? "$TEXMACS_HOME_PATH/system/preferences.scm")
 
114
      (set! saved-preferences
 
115
            (load-object "$TEXMACS_HOME_PATH/system/preferences.scm")))
 
116
  (fill-dictionary preferences-table saved-preferences))
 
117
 
 
118
(define (apply-preferences)
 
119
  (import-from (keyboard kbd-config) (texmacs texmacs tm-server)
 
120
               (texmacs texmacs tm-view) (texmacs texmacs tm-print)
 
121
               (texmacs tools tm-bracket))
 
122
  (map-in-order preference-apply (preferences->list preferences-table))
 
123
  (set! preferences-initialization-flag #t))