src/TeXmacs/progs/kernel/texmacs/tm-modes.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : tm-modes.scm
   5 ;; DESCRIPTION : defining new TeXmacs modes and some frequently used modes
   6 ;; COPYRIGHT   : (C) 2001  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-modes)
  15   (:use
  16     (kernel drd drd-rules) (kernel drd drd-query) (kernel drd drd-data)
  17     (kernel texmacs tm-plugins) (kernel texmacs tm-preferences)))
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;; Defining new modes
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22
  23 (define (texmacs-mode-pred mode)
  24   (let* ((mode-str (symbol->string mode))
  25          (mode-root (substring mode-str 0 (- (string-length mode-str) 1)))
  26          (pred-str (string-append mode-root "?")))
  27     (string->symbol pred-str)))
  28
  29 (define-public (texmacs-mode item)
  30   (with (mode action . deps) item
  31     (let* ((pred (texmacs-mode-pred mode))
  32            (deps* (map list (map texmacs-mode-pred deps)))
  33            (l (if (== action #t) deps* (cons action deps*)))
  34            (test (if (null? l) #t (if (null? (cdr l)) (car l) (cons 'and l))))
  35            (defn `(define-public (,pred) ,test))
  36            (rules (map (lambda (dep) (list dep mode)) deps))
  37            (drd-cmd `(drd-rules ,@rules))
  38            (arch1 `(set-symbol-procedure! ',mode ,pred))
  39            (arch2 `(set-symbol-procedure! ',pred ,pred)))
  40       (if (== mode 'always%) (set! defn '(noop)))
  41       (if (null? deps)
  42           (list 'begin defn arch1 arch2)
  43           (list 'begin defn arch1 arch2 drd-cmd)))))
  44
  45 (define-public-macro (texmacs-modes . l)
  46   `(begin ,@(map texmacs-mode l)))
  47
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49 ;; Checking modes
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51
  52 (define-public (texmacs-in-mode? mode)
  53   (with proc (symbol-procedure mode)
  54     (if proc (proc)
  55         (catch #t (lambda () (eval (list mode))) (lambda err #f)))))
  56
  57 (define-public (texmacs-mode-mode pred)
  58   "Get drd predicate name associated to scheme predicate or symbol"
  59   (if (procedure? pred)
  60       (with name (procedure-name pred)
  61         (if name (texmacs-mode-mode name) 'unknown%))
  62       (let* ((pred-str (symbol->string pred))
  63              (pred-root (substring pred-str 0 (- (string-length pred-str) 1)))
  64              (mode-str (string-append pred-root "%")))
  65         (string->symbol mode-str))))
  66
  67 (define texmacs-submode-table (make-ahash-table))
  68
  69 (define-public (texmacs-submode? what* of*)
  70   "Test whether @what* is a sub-mode of @of*"
  71   (let* ((key (cons what* of*))
  72          (handle (ahash-get-handle texmacs-submode-table key)))
  73     (if handle (cdr handle)
  74         (let* ((what (texmacs-mode-mode what*))
  75                (of (texmacs-mode-mode of*))
  76                (result (or (== of 'always%)
  77                            (== what 'prevail%)
  78                            (nnull? (query of what)))))
  79           (ahash-set! texmacs-submode-table key result)
  80           result))))
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83 ;; Checking whether certain features are supported
  84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85
  86 (define-public (supports-chinese?)
  87   (font-exists-in-tt? "fireflysung"))
  88
  89 (define-public (supports-japanese?)
  90   (font-exists-in-tt? "ipam"))
  91
  92 (define-public (supports-korean?)
  93   (font-exists-in-tt? "UnBatang"))
  94
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;; Mode related
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98
  99 (texmacs-modes
 100   (always% #t)
 101   (prevail% #t)
 102   (in-source% (== (get-env "mode") "src"))
 103   (in-text% (and (== (get-env "mode") "text") (not (in-graphics?))))
 104   (in-math% (and (== (get-env "mode") "math") (not (in-graphics?))))
 105   (in-prog% (and (== (get-env "mode") "prog") (not (in-graphics?))))
 106   (in-math-not-hybrid% (not (inside? 'hybrid)) in-math%)
 107   (in-table% (and (inside? 'table) (not (in-graphics?))))
 108   (in-session% (and (inside? 'session) (not (in-graphics?))))
 109   (in-session% (inside? 'session))
 110   (not-in-session% (not (inside? 'session)))
 111   (in-math-in-session% #t in-math% in-session%)
 112   (in-math-not-in-session% #t in-math% not-in-session%)
 113   (in-std% (style-has? "std-dtd"))
 114   (in-std-text% #t in-text% in-std%)
 115   (in-tmdoc% (style-has? "tmdoc-style"))
 116   (in-mmxdoc% (style-has? "mmxdoc-style") in-tmdoc%)
 117   (in-plugin-with-converters%
 118    (plugin-supports-math-input-ref (get-env "prog-language")))
 119   (with-any-selection% (selection-active-any?))
 120   (with-active-selection% (selection-active-normal?))
 121   (in-scheme% (== (get-env "prog-language") "scheme"))
 122   (in-prog-scheme% #t in-prog% in-scheme%))
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;; Language related
 126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 127
 128 (texmacs-modes
 129   (in-cyrillic% (in? (get-env "language")
 130                      '("bulgarian" "russian" "ukrainian")) in-text%)
 131   (in-oriental% (in? (get-env "language")
 132                      '("chinese" "japanese" "korean" "taiwanese")) in-text%)
 133   (in-bulgarian% (== (get-env "language") "bulgarian") in-cyrillic%)
 134   (in-chinese% (== (get-env "language") "chinese") in-oriental%)
 135   (in-czech% (== (get-env "language") "czech") in-text%)
 136   (in-danish% (== (get-env "language") "danish") in-text%)
 137   (in-dutch% (== (get-env "language") "dutch") in-text%)
 138   (in-english% (== (get-env "language") "english") in-text%)
 139   (in-finnish% (== (get-env "language") "finnish") in-text%)
 140   (in-french% (== (get-env "language") "french") in-text%)
 141   (in-german% (== (get-env "language") "german") in-text%)
 142   (in-hungarian% (== (get-env "language") "hungarian") in-text%)
 143   (in-italian% (== (get-env "language") "italian") in-text%)
 144   (in-japanese% (== (get-env "language") "japanese") in-oriental%)
 145   (in-korean% (== (get-env "language") "korean") in-oriental%)
 146   (in-polish% (== (get-env "language") "polish") in-text%)
 147   (in-portugese% (== (get-env "language") "portugese") in-text%)
 148   (in-romanian% (== (get-env "language") "romanian") in-text%)
 149   (in-russian% (== (get-env "language") "russian") in-cyrillic%)
 150   (in-slovene% (== (get-env "language") "slovene") in-text%)
 151   (in-spanish% (== (get-env "language") "spanish") in-text%)
 152   (in-swedish% (== (get-env "language") "swedish") in-text%)
 153   (in-taiwanese% (== (get-env "language") "taiwanese") in-oriental%)
 154   (in-ukrainian% (== (get-env "language") "ukrainian") in-cyrillic%))
 155
 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 ;; Keyboard related
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159
 160 (define (cyrillic-input-method? what)
 161   (== (get-preference "cyrillic input method") what))
 162
 163 (texmacs-modes
 164   (like-emacs% (== (get-preference "look and feel") "emacs"))
 165   (like-windows% (== (get-preference "look and feel") "windows"))
 166   (like-macos% (== (get-preference "look and feel") "macos"))
 167   (simple-menus% (== (get-preference "detailed menus") "simple"))
 168   (detailed-menus% (== (get-preference "detailed menus") "detailed"))
 169   (with-linking-tool% (== (get-preference "linking tool") "on"))
 170   (with-versioning-tool% (== (get-preference "versioning tool") "on"))
 171   (with-remote-connections% (== (get-preference "remote connections") "on"))
 172   (in-cyrillic-cp1251% (cyrillic-input-method? "cp1251") in-cyrillic%)
 173   (in-cyrillic-jcuken% (cyrillic-input-method? "jcuken") in-cyrillic%)
 174   (in-cyrillic-koi8% (cyrillic-input-method? "koi8") in-cyrillic%)
 175   (in-cyrillic-translit% (cyrillic-input-method? "translit") in-cyrillic%)
 176   (in-cyrillic-yawerty% (cyrillic-input-method? "yawerty") in-cyrillic%))