Mercurial > urweb

comparison src/elisp/urweb-util.el @ 350:3a1e36b14105

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