Mercurial > urweb

annotate src/elisp/urweb-util.el @ 1002:bb3fc575cfe7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Adapted existing demos to tuple pattern-matching
author Adam Chlipala <adamc@hcoop.net>
date Tue, 20 Oct 2009 10:29:17 -0400
parents 3a1e36b14105
children
rev   line source
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