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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE : tm-preferences.scm
;; DESCRIPTION : management of the user preferences
;; COPYRIGHT : (C) 1999 Joris van der Hoeven
;;
;; This software falls under the GNU general public license version 3 or later.
;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(texmacs-module (kernel texmacs tm-preferences)
(:use (kernel texmacs tm-define)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Defining preference call back routines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public preferences-table (make-ahash-table))
(define-public preferences-default (make-ahash-table))
(define-public preferences-call-back (make-ahash-table))
(define (define-preference x)
(with (which value call-back) x
`(if (not (ahash-ref preferences-default ,which))
(ahash-set! preferences-default ,which ,value))))
(define (define-preference-call-back x)
(with (which value call-back) x
`(begin
(ahash-set! preferences-call-back ,which ,call-back)
(notify-preference ,which))))
(define-public-macro (define-preferences . l)
(append '(begin)
(map-in-order define-preference l)
(map-in-order define-preference-call-back l)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Setting and getting preferences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-preference? which what)
(== what (get-preference which)))
(tm-define (set-preference which what)
(:synopsis "Set preference @which to @what")
(:check-mark "*" test-preference?)
(ahash-set! preferences-table which what)
;;(display* "set-preference " which " := " what "\n")
((get-call-back which) which (get-preference which))
(save-preferences))
(tm-define (reset-preference which)
(:synopsis "Revert preference @which to default setting")
(ahash-remove! preferences-table which)
((get-call-back which) which (get-preference which))
(save-preferences))
(tm-define (get-preference which)
(:synopsis "Get preference @which")
(if (ahash-ref preferences-table which)
(ahash-ref preferences-table which)
(ahash-ref preferences-default which)))
(define (preference-on? which)
(test-preference? which "on"))
(tm-define (toggle-preference which)
(:synopsis "Toggle the preference @which")
(:check-mark "v" preference-on?)
(let ((what (get-preference which)))
(set-preference which (cond ((== what "on") "off")
((== what "off") "on")
(else what)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Applying preferences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (get-call-back what)
(let ((r (ahash-ref preferences-call-back what)))
(if r r (lambda args (noop)))))
(define-public (notify-preference var)
"Notify a change in preference @var"
;;(display* "notify-preference " var ", " (get-preference var) "\n")
((get-call-back var) var (get-preference var)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialize preferences and consulting preferences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define user-preferences '())
(define saved-preferences '())
(define (preferences->list table)
(let* ((folder (lambda (key im tail) (cons (list key im) tail)))
(unsorted (ahash-fold folder '() table))
(comp? (lambda (l1 l2) (string<=? (car l1) (car l2)))))
(list-sort unsorted comp?)))
(define (save-preferences)
(set! user-preferences (preferences->list preferences-table))
(if (!= user-preferences saved-preferences)
(begin
(save-object "$TEXMACS_HOME_PATH/system/preferences.scm"
user-preferences)
(set! saved-preferences user-preferences))))
(define (retrieve-preferences)
"Retrieve preferences from disk"
(if (url-exists? "$TEXMACS_HOME_PATH/system/preferences.scm")
(set! saved-preferences
(load-object "$TEXMACS_HOME_PATH/system/preferences.scm")))
(fill-dictionary preferences-table saved-preferences))
(retrieve-preferences)
|