src/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 version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (kernel texmacs tm-preferences)
  15   (:use (kernel texmacs tm-define)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Defining preference call back routines
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (define-public preferences-table (make-ahash-table))
  22 (define-public preferences-default (make-ahash-table))
  23 (define-public preferences-call-back (make-ahash-table))
  24
  25 (define (define-preference x)
  26   (with (which value call-back) x
  27     `(if (not (ahash-ref preferences-default ,which))
  28          (ahash-set! preferences-default ,which ,value))))
  29
  30 (define (define-preference-call-back x)
  31   (with (which value call-back) x
  32     `(begin
  33        (ahash-set! preferences-call-back ,which ,call-back)
  34        (notify-preference ,which))))
  35
  36 (define-public-macro (define-preferences . l)
  37   (append '(begin)
  38           (map-in-order define-preference l)
  39           (map-in-order define-preference-call-back l)))
  40
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42 ;; Setting and getting preferences
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44
  45 (define (test-preference? which what)
  46   (== what (get-preference which)))
  47
  48 (tm-define (set-preference which what)
  49   (:synopsis "Set preference @which to @what")
  50   (:check-mark "*" test-preference?)
  51   (ahash-set! preferences-table which what)
  52   ;;(display* "set-preference " which " := " what "\n")
  53   ((get-call-back which) which (get-preference which))
  54   (save-preferences))
  55
  56 (tm-define (reset-preference which)
  57   (:synopsis "Revert preference @which to default setting")
  58   (ahash-remove! preferences-table which)
  59   ((get-call-back which) which (get-preference which))
  60   (save-preferences))
  61
  62 (tm-define (get-preference which)
  63   (:synopsis "Get preference @which")
  64   (if (ahash-ref preferences-table which)
  65       (ahash-ref preferences-table which)
  66       (ahash-ref preferences-default which)))
  67
  68 (define (preference-on? which)
  69   (test-preference? which "on"))
  70
  71 (tm-define (toggle-preference which)
  72   (:synopsis "Toggle the preference @which")
  73   (:check-mark "v" preference-on?)
  74   (let ((what (get-preference which)))
  75     (set-preference which (cond ((== what "on") "off")
  76                                 ((== what "off") "on")
  77                                 (else what)))))
  78
  79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80 ;; Applying preferences
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (define (get-call-back what)
  84   (let ((r (ahash-ref preferences-call-back what)))
  85     (if r r (lambda args (noop)))))
  86
  87 (define-public (notify-preference var)
  88   "Notify a change in preference @var"
  89   ;;(display* "notify-preference " var ", " (get-preference var) "\n")
  90   ((get-call-back var) var (get-preference var)))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;; Initialize preferences and consulting preferences
  94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95
  96 (define user-preferences '())
  97 (define saved-preferences '())
  98
  99 (define (preferences->list table)
 100   (let* ((folder (lambda (key im tail) (cons (list key im) tail)))
 101          (unsorted (ahash-fold folder '() table))
 102          (comp? (lambda (l1 l2) (string<=? (car l1) (car l2)))))
 103     (list-sort unsorted comp?)))
 104
 105 (define (save-preferences)
 106   (set! user-preferences (preferences->list preferences-table))
 107   (if (!= user-preferences saved-preferences)
 108       (begin
 109         (save-object "$TEXMACS_HOME_PATH/system/preferences.scm"
 110                      user-preferences)
 111         (set! saved-preferences user-preferences))))
 112
 113 (define (retrieve-preferences)
 114   "Retrieve preferences from disk"
 115   (if (url-exists? "$TEXMACS_HOME_PATH/system/preferences.scm")
 116       (set! saved-preferences
 117             (load-object "$TEXMACS_HOME_PATH/system/preferences.scm")))
 118   (fill-dictionary preferences-table saved-preferences))
 119
 120 (retrieve-preferences)