adamc@350
|
1 ;;; urweb-util.el --- Utility functions for urweb-mode
|
adamc@350
|
2
|
adamc@350
|
3 ;; Based on sml-mode:
|
adamc@350
|
4 ;; Copyright (C) 1999-2000 Stefan Monnier <monnier@cs.yale.edu>
|
adamc@350
|
5 ;;
|
adamc@350
|
6 ;; Modified for urweb-mode:
|
adamc@350
|
7 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
|
adamc@350
|
8 ;;
|
adamc@350
|
9 ;; This program is free software; you can redistribute it and/or modify
|
adamc@350
|
10 ;; it under the terms of the GNU General Public License as published by
|
adamc@350
|
11 ;; the Free Software Foundation; either version 2 of the License, or
|
adamc@350
|
12 ;; (at your option) any later version.
|
adamc@350
|
13 ;;
|
adamc@350
|
14 ;; This program is distributed in the hope that it will be useful,
|
adamc@350
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
adamc@350
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
adamc@350
|
17 ;; GNU General Public License for more details.
|
adamc@350
|
18 ;;
|
adamc@350
|
19 ;; You should have received a copy of the GNU General Public License
|
adamc@350
|
20 ;; along with this program; if not, write to the Free Software
|
adamc@350
|
21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
adamc@350
|
22
|
adamc@350
|
23
|
adamc@350
|
24 ;;; Commentary:
|
adamc@350
|
25
|
adamc@350
|
26 ;;; Code:
|
adamc@350
|
27
|
adamc@350
|
28 (require 'cl) ;for `reduce'
|
adamc@350
|
29 (require 'urweb-compat)
|
adamc@350
|
30
|
adamc@350
|
31 ;;
|
adamc@350
|
32
|
adamc@350
|
33 (defun flatten (ls &optional acc)
|
adamc@350
|
34 (if (null ls) acc
|
adamc@350
|
35 (let ((rest (flatten (cdr ls) acc))
|
adamc@350
|
36 (head (car ls)))
|
adamc@350
|
37 (if (listp head)
|
adamc@350
|
38 (flatten head rest)
|
adamc@350
|
39 (cons head rest)))))
|
adamc@350
|
40
|
adamc@350
|
41 (defun urweb-preproc-alist (al)
|
adamc@350
|
42 "Expand an alist AL where keys can be lists of keys into a normal one."
|
adamc@350
|
43 (reduce (lambda (x al)
|
adamc@350
|
44 (let ((k (car x))
|
adamc@350
|
45 (v (cdr x)))
|
adamc@350
|
46 (if (consp k)
|
adamc@350
|
47 (append (mapcar (lambda (y) (cons y v)) k) al)
|
adamc@350
|
48 (cons x al))))
|
adamc@350
|
49 al
|
adamc@350
|
50 :initial-value nil
|
adamc@350
|
51 :from-end t))
|
adamc@350
|
52
|
adamc@350
|
53 ;;;
|
adamc@350
|
54 ;;; defmap
|
adamc@350
|
55 ;;;
|
adamc@350
|
56
|
adamc@350
|
57 (defun custom-create-map (m bs args)
|
adamc@350
|
58 (let (inherit dense suppress)
|
adamc@350
|
59 (while args
|
adamc@350
|
60 (let ((key (first args))
|
adamc@350
|
61 (val (second args)))
|
adamc@350
|
62 (cond
|
adamc@350
|
63 ((eq key :dense) (setq dense val))
|
adamc@350
|
64 ((eq key :inherit) (setq inherit val))
|
adamc@350
|
65 ((eq key :group) )
|
adamc@350
|
66 ;;((eq key :suppress) (setq suppress val))
|
adamc@350
|
67 (t (message "Uknown argument %s in defmap" key))))
|
adamc@350
|
68 (setq args (cddr args)))
|
adamc@350
|
69 (unless (keymapp m)
|
adamc@350
|
70 (setq bs (append m bs))
|
adamc@350
|
71 (setq m (if dense (make-keymap) (make-sparse-keymap))))
|
adamc@350
|
72 (dolist (b bs)
|
adamc@350
|
73 (let ((keys (car b))
|
adamc@350
|
74 (binding (cdr b)))
|
adamc@350
|
75 (dolist (key (if (consp keys) keys (list keys)))
|
adamc@350
|
76 (cond
|
adamc@350
|
77 ((symbolp key)
|
adamc@350
|
78 (substitute-key-definition key binding m global-map))
|
adamc@350
|
79 ((null binding)
|
adamc@350
|
80 (unless (keymapp (lookup-key m key)) (define-key m key binding)))
|
adamc@350
|
81 ((let ((o (lookup-key m key)))
|
adamc@350
|
82 (or (null o) (numberp o) (eq o 'undefined)))
|
adamc@350
|
83 (define-key m key binding))))))
|
adamc@350
|
84 (cond
|
adamc@350
|
85 ((keymapp inherit) (set-keymap-parent m inherit))
|
adamc@350
|
86 ((consp inherit) (set-keymap-parents m inherit)))
|
adamc@350
|
87 m))
|
adamc@350
|
88
|
adamc@350
|
89 (defmacro defmap (m bs doc &rest args)
|
adamc@350
|
90 `(defconst ,m
|
adamc@350
|
91 (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args))
|
adamc@350
|
92 ,doc))
|
adamc@350
|
93
|
adamc@350
|
94 ;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
adamc@350
|
95
|
adamc@350
|
96 (defun custom-create-syntax (css args)
|
adamc@350
|
97 (let ((st (make-syntax-table (cadr (memq :copy args)))))
|
adamc@350
|
98 (dolist (cs css)
|
adamc@350
|
99 (let ((char (car cs))
|
adamc@350
|
100 (syntax (cdr cs)))
|
adamc@350
|
101 (if (sequencep char)
|
adamc@350
|
102 (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char)
|
adamc@350
|
103 (modify-syntax-entry char syntax st))))
|
adamc@350
|
104 st))
|
adamc@350
|
105
|
adamc@350
|
106 (defmacro defsyntax (st css doc &rest args)
|
adamc@350
|
107 `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc))
|
adamc@350
|
108
|
adamc@350
|
109 ;;;;
|
adamc@350
|
110 ;;;; Compatibility info
|
adamc@350
|
111 ;;;;
|
adamc@350
|
112
|
adamc@350
|
113 (defvar urweb-builtin-nested-comments-flag
|
adamc@350
|
114 (ignore-errors
|
adamc@350
|
115 (not (equal (let ((st (make-syntax-table)))
|
adamc@350
|
116 (modify-syntax-entry ?\* ". 23n" st) st)
|
adamc@350
|
117 (let ((st (make-syntax-table)))
|
adamc@350
|
118 (modify-syntax-entry ?\* ". 23" st) st))))
|
adamc@350
|
119 "Non-nil means this Emacs understands the `n' in syntax entries.")
|
adamc@350
|
120
|
adamc@350
|
121 (provide 'urweb-util)
|
adamc@350
|
122
|
adamc@350
|
123 ;;; urweb-util.el ends here
|