Mercurial > urweb

annotate src/elisp/urweb-mode.el @ 1640:dc986eb6113c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Order constructors properly in wildification, to avoid spuriously displeasing the new scoping check
author Adam Chlipala <adam@chlipala.net>
date Sun, 18 Dec 2011 12:00:36 -0500
parents da788bd72c9e
children ac141fbb313a
rev   line source
adamc@350 1 ;;; urweb-mode.el --- Major mode for editing (Standard) ML
adamc@350 2
adamc@350 3 ;; Based on sml-mode:
adamc@350 4 ;; Copyright (C) 1999,2000,2004 Stefan Monnier
adamc@350 5 ;; Copyright (C) 1994-1997 Matthew J. Morley
adamc@350 6 ;; Copyright (C) 1989 Lars Bo Nielsen
adamc@350 7 ;;
adamc@350 8 ;; Modified for urweb-mode:
adamc@350 9 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
adamc@350 10
adamc@350 11 ;; Author: Lars Bo Nielsen
adamc@350 12 ;; Olin Shivers
adamc@350 13 ;; Fritz Knabe (?)
adamc@350 14 ;; Steven Gilmore (?)
adamc@350 15 ;; Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>)
adamc@350 16 ;; Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>)
adamc@350 17 ;; (Stefan Monnier) monnier@cs.yale.edu
adamc@350 18 ;; Adam Chlipala
adamc@350 19
adamc@350 20 ;; This file is not part of GNU Emacs, but it is distributed under the
adamc@350 21 ;; same conditions.
adamc@350 22
adamc@350 23 ;; This program is free software; you can redistribute it and/or
adamc@350 24 ;; modify it under the terms of the GNU General Public License as
adamc@350 25 ;; published by the Free Software Foundation; either version 2, or (at
adamc@350 26 ;; your option) any later version.
adamc@350 27
adamc@350 28 ;; This program is distributed in the hope that it will be useful, but
adamc@350 29 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
adamc@350 30 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
adamc@350 31 ;; General Public License for more details.
adamc@350 32
adamc@350 33 ;; You should have received a copy of the GNU General Public License
adamc@350 34 ;; along with GNU Emacs; see the file COPYING. If not, write to the
adamc@350 35 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
adamc@350 36
adamc@350 37 ;;; Commentary:
adamc@350 38
adamc@350 39 ;;; HISTORY
adamc@350 40
adamc@350 41 ;; Still under construction: History obscure, needs a biographer as
adamc@350 42 ;; well as a M-x doctor. Change Log on request.
adamc@350 43
adamc@358 44 ;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el.
adamc@350 45
adamc@350 46 ;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and
adamc@350 47 ;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus,
adamc@350 48 ;; and numerous bugs and bug-fixes.
adamc@350 49
adamc@350 50 ;;; DESCRIPTION
adamc@350 51
adamc@350 52 ;; See accompanying info file: urweb-mode.info
adamc@350 53
adamc@350 54 ;;; FOR YOUR .EMACS FILE
adamc@350 55
adamc@350 56 ;; If urweb-mode.el lives in some non-standard directory, you must tell
adamc@350 57 ;; emacs where to get it. This may or may not be necessary:
adamc@350 58
adamc@350 59 ;; (add-to-list 'load-path "~jones/lib/emacs/")
adamc@350 60
adamc@350 61 ;; Then to access the commands autoload urweb-mode with that command:
adamc@350 62
adamc@350 63 ;; (load "urweb-mode-startup")
adamc@350 64
adamc@350 65 ;; urweb-mode-hook is run whenever a new urweb-mode buffer is created.
adamc@350 66
adamc@350 67 ;;; Code:
adamc@350 68
adamc@350 69 (eval-when-compile (require 'cl))
adamc@350 70 (require 'urweb-util)
adamc@350 71 (require 'urweb-move)
adamc@350 72 (require 'urweb-defs)
adamc@350 73 (condition-case nil (require 'skeleton) (error nil))
adamc@350 74
adamc@350 75 ;;; VARIABLES CONTROLLING INDENTATION
adamc@350 76
adamc@350 77 (defcustom urweb-indent-level 4
adamc@350 78 "*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')."
adamc@350 79 :group 'urweb
adamc@350 80 :type '(integer))
adamc@350 81
adamc@350 82 (defcustom urweb-indent-args urweb-indent-level
adamc@350 83 "*Indentation of args placed on a separate line."
adamc@350 84 :group 'urweb
adamc@350 85 :type '(integer))
adamc@350 86
adamc@350 87 (defcustom urweb-electric-semi-mode nil
adamc@350 88 "*If non-nil, `\;' will self insert, reindent the line, and do a newline.
adamc@350 89 If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)."
adamc@350 90 :group 'urweb
adamc@350 91 :type 'boolean)
adamc@350 92
adamc@350 93 (defcustom urweb-rightalign-and t
adamc@350 94 "If non-nil, right-align `and' with its leader.
adamc@350 95 If nil: If t:
adamc@350 96 datatype a = A datatype a = A
adamc@350 97 and b = B and b = B"
adamc@350 98 :group 'urweb
adamc@350 99 :type 'boolean)
adamc@350 100
adamc@350 101 ;;; OTHER GENERIC MODE VARIABLES
adamc@350 102
adamc@350 103 (defvar urweb-mode-info "urweb-mode"
adamc@350 104 "*Where to find Info file for `urweb-mode'.
adamc@350 105 The default assumes the info file \"urweb-mode.info\" is on Emacs' info
adamc@350 106 directory path. If it is not, either put the file on the standard path
adamc@350 107 or set the variable `urweb-mode-info' to the exact location of this file
adamc@350 108
adamc@350 109 (setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\")
adamc@350 110
adamc@350 111 in your .emacs file. You can always set it interactively with the
adamc@350 112 set-variable command.")
adamc@350 113
adamc@350 114 (defvar urweb-mode-hook nil
adamc@350 115 "*Run upon entering `urweb-mode'.
adamc@350 116 This is a good place to put your preferred key bindings.")
adamc@350 117
adamc@350 118 ;;; CODE FOR Ur/Web-MODE
adamc@350 119
adamc@350 120 (defun urweb-mode-info ()
adamc@350 121 "Command to access the TeXinfo documentation for `urweb-mode'.
adamc@350 122 See doc for the variable `urweb-mode-info'."
adamc@350 123 (interactive)
adamc@350 124 (require 'info)
adamc@350 125 (condition-case nil
adamc@350 126 (info urweb-mode-info)
adamc@350 127 (error (progn
adamc@350 128 (describe-variable 'urweb-mode-info)
adamc@350 129 (message "Can't find it... set this variable first!")))))
adamc@350 130
adamc@350 131
adamc@350 132 ;; font-lock setup
adamc@350 133
adamc@350 134 (defconst urweb-keywords-regexp
adamc@350 135 (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints"
adamc@621 136 "datatype" "else" "end" "extern" "fn" "map"
adamc@350 137 "fun" "functor" "if" "include"
adamc@446 138 "of" "open" "let" "in"
adamc@1199 139 "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
adamc@754 140 "struct" "structure" "table" "view" "then" "type" "val" "where"
adamc@350 141 "with"
adamc@350 142
adamc@350 143 "Name" "Type" "Unit")
adamc@350 144 "A regexp that matches any non-SQL keywords of Ur/Web.")
adamc@350 145
adamc@350 146 (defconst urweb-sql-keywords-regexp
adamc@993 147 (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
adamc@350 148 "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
adamc@350 149 "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
adamc@708 150 "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
adamc@714 151 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
adamc@749 152 "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
kkallio@1572 153 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
kkallio@1607 154 "IF" "THEN" "ELSE" "COALESCE" "LIKE")
adamc@350 155 "A regexp that matches SQL keywords.")
adamc@350 156
adamc@351 157 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
adamc@351 158 "A regexp that matches lowercase Ur/Web identifiers.")
adamc@351 159
adamc@351 160 (defconst urweb-cident-regexp "\\<[A-Z][A-Za-z0-9_']*\\>"
adamc@351 161 "A regexp that matches uppercase Ur/Web identifiers.")
adamc@351 162
adamc@350 163 ;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
adamc@350 164
adamc@350 165 ;; The font lock regular expressions.
adamc@350 166
adamc@363 167 (defun urweb-in-xml ()
adamc@360 168 (save-excursion
adamc@360 169 (let (
adamc@360 170 (depth 0)
adamc@360 171 (finished nil)
adamc@360 172 (answer nil)
adamc@360 173 )
vshabanoff@1566 174 (while (and (not finished) (re-search-backward "[-<{}]" nil t))
adamc@360 175 (cond
adamc@360 176 ((looking-at "{")
adamc@360 177 (if (> depth 0)
adamc@363 178 (decf depth)
adamc@360 179 (setq finished t)))
adamc@360 180 ((looking-at "}")
adamc@363 181 (incf depth))
adam@1525 182 ((looking-at "<xml>")
adam@1525 183 (if (> depth 0)
adam@1525 184 (decf depth)
adam@1525 185 (progn
adam@1525 186 (setq answer t)
adam@1525 187 (setq finished t))))
adam@1525 188 ((looking-at "</xml>")
vshabanoff@1565 189 (incf depth))
vshabanoff@1565 190
vshabanoff@1566 191 ((looking-at "-")
vshabanoff@1566 192 (if (looking-at "->")
vshabanoff@1566 193 (setq finished (= depth 0))))
vshabanoff@1566 194
vshabanoff@1565 195 ((and (= depth 0)
vshabanoff@1565 196 (not (looking-at "<xml")) ;; ignore <xml/>
vshabanoff@1565 197 (eq font-lock-tag-face
vshabanoff@1565 198 (get-text-property (point) 'face)))
vshabanoff@1565 199 ;; previous code was highlighted as tag, seems we are in xml
vshabanoff@1565 200 (progn
vshabanoff@1565 201 (setq answer t)
vshabanoff@1565 202 (setq finished t)))
vshabanoff@1565 203
vshabanoff@1565 204 ((= depth 0)
vshabanoff@1565 205 ;; previous thing was a tag like, but not tag
vshabanoff@1565 206 ;; seems we are in usual code or comment
vshabanoff@1565 207 (setq finished t))
vshabanoff@1565 208 ))
adamc@360 209 answer)))
adamc@360 210
adamc@360 211 (defun amAttribute (face)
adamc@360 212 (if (ignore-errors (save-excursion (backward-word 2) (backward-char 1) (looking-at "<")))
adamc@360 213 nil
adamc@360 214 face))
adamc@358 215
adamc@350 216 (defconst urweb-font-lock-keywords
adamc@350 217 `(;;(urweb-font-comments-and-strings)
adamc@362 218 ("\\(<\\sw+\\)\\(\\s-\\|\\sw\\|=\\|\"[^\"]*\"\\|{[^}]*}\\)*\\(/?>\\)"
adamc@359 219 (1 font-lock-tag-face)
adamc@359 220 (3 font-lock-tag-face))
adamc@359 221 ("\\(</\\sw+>\\)"
adamc@359 222 (1 font-lock-tag-face))
adamc@359 223 ("\\([^<>{}]+\\)"
adamc@363 224 (1 (if (urweb-in-xml)
adamc@359 225 font-lock-string-face
adamc@359 226 nil)))
adamc@359 227
adamc@357 228 ("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]"
adamc@350 229 (1 font-lock-keyword-face)
adamc@360 230 (2 (amAttribute font-lock-function-name-face)))
adamc@357 231 ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
adamc@350 232 (1 font-lock-keyword-face)
adamc@360 233 (3 (amAttribute font-lock-type-def-face)))
adamc@1199 234 ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
adamc@350 235 (1 font-lock-keyword-face)
adamc@360 236 (3 (amAttribute font-lock-variable-name-face)))
adamc@350 237 ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
adamc@350 238 (1 font-lock-keyword-face)
adamc@360 239 (2 (amAttribute font-lock-module-def-face)))
adamc@350 240 ("\\<\\(signature\\)\\s-+\\(\\sw+\\)"
adamc@350 241 (1 font-lock-keyword-face)
adamc@360 242 (2 (amAttribute font-lock-interface-def-face)))
adamc@350 243
adamc@350 244 (,urweb-keywords-regexp . font-lock-keyword-face)
adamc@351 245 (,urweb-sql-keywords-regexp . font-lock-sql-face)
adamc@351 246 (,urweb-cident-regexp . font-lock-cvariable-face))
adamc@350 247 "Regexps matching standard Ur/Web keywords.")
adamc@350 248
adamc@350 249 (defface font-lock-type-def-face
adamc@350 250 '((t (:bold t)))
adamc@350 251 "Font Lock mode face used to highlight type definitions."
adamc@350 252 :group 'font-lock-highlighting-faces)
adamc@350 253 (defvar font-lock-type-def-face 'font-lock-type-def-face
adamc@350 254 "Face name to use for type definitions.")
adamc@350 255
adamc@350 256 (defface font-lock-module-def-face
adamc@350 257 '((t (:bold t)))
adamc@350 258 "Font Lock mode face used to highlight module definitions."
adamc@350 259 :group 'font-lock-highlighting-faces)
adamc@350 260 (defvar font-lock-module-def-face 'font-lock-module-def-face
adamc@350 261 "Face name to use for module definitions.")
adamc@350 262
adamc@350 263 (defface font-lock-interface-def-face
adamc@350 264 '((t (:bold t)))
adamc@350 265 "Font Lock mode face used to highlight interface definitions."
adamc@350 266 :group 'font-lock-highlighting-faces)
adamc@350 267 (defvar font-lock-interface-def-face 'font-lock-interface-def-face
adamc@350 268 "Face name to use for interface definitions.")
adamc@350 269
adamc@350 270 (defface font-lock-sql-face
adamc@350 271 '((t (:bold t)))
adamc@350 272 "Font Lock mode face used to highlight SQL keywords."
adamc@350 273 :group 'font-lock-highlighting-faces)
adamc@350 274 (defvar font-lock-sql-face 'font-lock-sql-face
adamc@350 275 "Face name to use for SQL keywords.")
adamc@350 276
adamc@351 277 (defface font-lock-cvariable-face
adamc@351 278 '((t (:foreground "dark blue")))
adamc@351 279 "Font Lock mode face used to highlight capitalized identifiers."
adamc@351 280 :group 'font-lock-highlighting-faces)
adamc@351 281 (defvar font-lock-cvariable-face 'font-lock-cvariable-face
adamc@351 282 "Face name to use for capitalized identifiers.")
adamc@351 283
adamc@357 284 (defface font-lock-tag-face
adamc@357 285 '((t (:bold t)))
adamc@357 286 "Font Lock mode face used to highlight XML tags."
adamc@357 287 :group 'font-lock-highlighting-faces)
adamc@357 288 (defvar font-lock-tag-face 'font-lock-tag-face
adamc@357 289 "Face name to use for XML tags.")
adamc@357 290
adamc@358 291 (defface font-lock-attr-face
adamc@358 292 '((t (:bold t)))
adamc@358 293 "Font Lock mode face used to highlight XML attributes."
adamc@358 294 :group 'font-lock-highlighting-faces)
adamc@358 295 (defvar font-lock-attr-face 'font-lock-attr-face
adamc@358 296 "Face name to use for XML attributes.")
adamc@358 297
adamc@350 298 ;;
adamc@350 299 ;; Code to handle nested comments and unusual string escape sequences
adamc@350 300 ;;
adamc@350 301
adamc@350 302 (defsyntax urweb-syntax-prop-table
adamc@350 303 '((?\\ . ".") (?* . "."))
adamc@350 304 "Syntax table for text-properties")
adamc@350 305
adamc@350 306 ;; For Emacsen that have no built-in support for nested comments
adamc@350 307 (defun urweb-get-depth-st ()
adamc@350 308 (save-excursion
adamc@350 309 (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil))
adamc@350 310 (_ (backward-char))
adamc@350 311 (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp))
adamc@350 312 (pt (point)))
adamc@350 313 (when disp
adamc@350 314 (let* ((depth
adamc@350 315 (save-match-data
adamc@350 316 (if (re-search-backward "\\*)\\|(\\*" nil t)
adamc@350 317 (+ (or (get-char-property (point) 'comment-depth) 0)
adamc@350 318 (case (char-after) (?\( 1) (?* 0))
adamc@350 319 disp)
adamc@350 320 0)))
adamc@350 321 (depth (if (> depth 0) depth)))
adamc@350 322 (put-text-property pt (1+ pt) 'comment-depth depth)
adamc@350 323 (when depth urweb-syntax-prop-table))))))
adamc@350 324
adamc@350 325 (defconst urweb-font-lock-syntactic-keywords
adamc@350 326 `(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table))
adamc@350 327 ,@(unless urweb-builtin-nested-comments-flag
adamc@350 328 '(("(?\\(\\*\\))?" (1 (urweb-get-depth-st)))))))
adamc@350 329
adamc@350 330 (defconst urweb-font-lock-defaults
adamc@350 331 '(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil
adamc@350 332 (font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords)))
adamc@350 333
adamc@350 334 ;;;;
adamc@350 335 ;;;; Imenu support
adamc@350 336 ;;;;
adamc@350 337
adamc@350 338 (defvar urweb-imenu-regexp
adamc@350 339 (concat "^[ \t]*\\(let[ \t]+\\)?"
adamc@350 340 (regexp-opt (append urweb-module-head-syms
adamc@350 341 '("and" "fun" "datatype" "type")) t)
adamc@350 342 "\\>"))
adamc@350 343
adamc@350 344 (defun urweb-imenu-create-index ()
adamc@350 345 (let (alist)
adamc@350 346 (goto-char (point-max))
adamc@350 347 (while (re-search-backward urweb-imenu-regexp nil t)
adamc@350 348 (save-excursion
adamc@350 349 (let ((kind (match-string 2))
adamc@350 350 (column (progn (goto-char (match-beginning 2)) (current-column)))
adamc@350 351 (location
adamc@350 352 (progn (goto-char (match-end 0))
adamc@350 353 (urweb-forward-spaces)
adamc@350 354 (when (looking-at urweb-tyvarseq-re)
adamc@350 355 (goto-char (match-end 0)))
adamc@350 356 (point)))
adamc@350 357 (name (urweb-forward-sym)))
adamc@350 358 ;; Eliminate trivial renamings.
adamc@350 359 (when (or (not (member kind '("structure" "signature")))
adamc@350 360 (progn (search-forward "=")
adamc@350 361 (urweb-forward-spaces)
adamc@350 362 (looking-at "sig\\|struct")))
adamc@350 363 (push (cons (concat (make-string (/ column 2) ?\ ) name) location)
adamc@350 364 alist)))))
adamc@350 365 alist))
adamc@350 366
adamc@350 367 ;;; MORE CODE FOR URWEB-MODE
adamc@350 368
adamc@350 369 ;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name))
adamc@350 370 ;;;###autoload
adamc@362 371 (add-to-list 'auto-mode-alist '("\\.urs?\\'" . urweb-mode))
adamc@350 372
adamc@350 373 ;;;###autoload
adamc@350 374 (define-derived-mode urweb-mode fundamental-mode "Ur/Web"
adamc@350 375 "\\<urweb-mode-map>Major mode for editing Ur/Web code.
adamc@350 376 This mode runs `urweb-mode-hook' just before exiting.
adamc@350 377 \\{urweb-mode-map}"
adamc@350 378 (set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults)
adamc@358 379 (set (make-local-variable 'font-lock-multiline) 'undecided)
adamc@350 380 (set (make-local-variable 'outline-regexp) urweb-outline-regexp)
adamc@350 381 (set (make-local-variable 'imenu-create-index-function)
adamc@350 382 'urweb-imenu-create-index)
adamc@350 383 (set (make-local-variable 'add-log-current-defun-function)
adamc@350 384 'urweb-current-fun-name)
adamc@350 385 ;; Treat paragraph-separators in comments as paragraph-separators.
adamc@350 386 (set (make-local-variable 'paragraph-separate)
adamc@350 387 (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)"))
adamc@350 388 (set (make-local-variable 'require-final-newline) t)
adamc@350 389 ;; forward-sexp-function is an experimental variable in my hacked Emacs.
adamc@350 390 (set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp)
adamc@350 391 ;; For XEmacs
adamc@350 392 (easy-menu-add urweb-mode-menu)
adamc@358 393
adamc@350 394 ;; Compatibility. FIXME: we should use `-' in Emacs-CVS.
adamc@350 395 (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil))
adamc@358 396
adamc@360 397 (urweb-mode-variables))
adamc@350 398
adamc@350 399 (defun urweb-mode-variables ()
adamc@350 400 (set-syntax-table urweb-mode-syntax-table)
adamc@350 401 (setq local-abbrev-table urweb-mode-abbrev-table)
adamc@350 402 ;; A paragraph is separated by blank lines or ^L only.
adamc@350 403
adamc@350 404 (set (make-local-variable 'indent-line-function) 'urweb-indent-line)
adamc@350 405 (set (make-local-variable 'comment-start) "(* ")
adamc@350 406 (set (make-local-variable 'comment-end) " *)")
adamc@350 407 (set (make-local-variable 'comment-nested) t)
adamc@350 408 ;;(set (make-local-variable 'block-comment-start) "* ")
adamc@350 409 ;;(set (make-local-variable 'block-comment-end) "")
adamc@350 410 ;; (set (make-local-variable 'comment-column) 40)
adamc@350 411 (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))
adamc@350 412
adamc@350 413 (defun urweb-funname-of-and ()
adamc@350 414 "Name of the function this `and' defines, or nil if not a function.
adamc@350 415 Point has to be right after the `and' symbol and is not preserved."
adamc@350 416 (urweb-forward-spaces)
adamc@350 417 (if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0)))
adamc@350 418 (let ((sym (urweb-forward-sym)))
adamc@350 419 (urweb-forward-spaces)
adamc@350 420 (unless (or (member sym '(nil "d="))
adamc@350 421 (member (urweb-forward-sym) '("d=")))
adamc@350 422 sym)))
adamc@350 423
adamc@350 424 ;;; INDENTATION !!!
adamc@350 425
adamc@350 426 (defun urweb-mark-function ()
adamc@350 427 "Synonym for `mark-paragraph' -- sorry.
adamc@350 428 If anyone has a good algorithm for this..."
adamc@350 429 (interactive)
adamc@350 430 (mark-paragraph))
adamc@350 431
adamc@350 432 (defun urweb-indent-line ()
adamc@350 433 "Indent current line of Ur/Web code."
adamc@350 434 (interactive)
adamc@350 435 (let ((savep (> (current-column) (current-indentation)))
adamc@350 436 (indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0)))
adamc@350 437 (if savep
adamc@350 438 (save-excursion (indent-line-to indent))
adamc@350 439 (indent-line-to indent))))
adamc@350 440
adamc@350 441 (defun urweb-back-to-outer-indent ()
adamc@350 442 "Unindents to the next outer level of indentation."
adamc@350 443 (interactive)
adamc@350 444 (save-excursion
adamc@350 445 (beginning-of-line)
adamc@350 446 (skip-chars-forward "\t ")
adamc@350 447 (let ((start-column (current-column))
adamc@350 448 (indent (current-column)))
adamc@350 449 (if (> start-column 0)
adamc@350 450 (progn
adamc@350 451 (save-excursion
adamc@350 452 (while (>= indent start-column)
adamc@350 453 (if (re-search-backward "^[^\n]" nil t)
adamc@350 454 (setq indent (current-indentation))
adamc@350 455 (setq indent 0))))
adamc@350 456 (backward-delete-char-untabify (- start-column indent)))))))
adamc@350 457
adamc@350 458 (defun urweb-find-comment-indent ()
adamc@350 459 (save-excursion
adamc@350 460 (let ((depth 1))
adamc@350 461 (while (> depth 0)
adamc@350 462 (if (re-search-backward "(\\*\\|\\*)" nil t)
adamc@350 463 (cond
adamc@350 464 ;; FIXME: That's just a stop-gap.
adamc@350 465 ((eq (get-text-property (point) 'face) 'font-lock-string-face))
adamc@350 466 ((looking-at "*)") (incf depth))
adamc@350 467 ((looking-at comment-start-skip) (decf depth)))
adamc@350 468 (setq depth -1)))
adamc@350 469 (if (= depth 0)
adamc@350 470 (1+ (current-column))
adamc@350 471 nil))))
adamc@350 472
adamc@369 473 (defun urweb-empty-line ()
adamc@365 474 (save-excursion
adamc@369 475 (beginning-of-line)
adamc@365 476 (let ((start-pos (point)))
adamc@369 477 (end-of-line)
adamc@369 478 (not (re-search-backward "[^\n \t]" start-pos t)))))
adamc@365 479
adamc@369 480 (defun urweb-seek-back ()
adamc@369 481 (while (urweb-empty-line) (previous-line 1)))
adamc@363 482
adamc@369 483 (defun urweb-skip-matching-braces ()
adamc@367 484 "Skip backwards past matching brace pairs, to calculate XML indentation after quoted Ur code"
adamc@367 485 (beginning-of-line)
adamc@367 486 (let ((start-pos (point))
adamc@367 487 (depth 0))
adamc@367 488 (end-of-line)
adamc@367 489 (while (re-search-backward "[{}]" start-pos t)
adamc@367 490 (cond
adamc@367 491 ((looking-at "}")
adamc@367 492 (incf depth))
adamc@367 493 ((looking-at "{")
adamc@367 494 (decf depth))))
adamc@367 495 (while (and (> depth 0) (re-search-backward "[{}]" nil t)
adamc@367 496 (cond
adamc@367 497 ((looking-at "}")
adamc@367 498 (incf depth))
adamc@367 499 ((looking-at "{")
adamc@367 500 (decf depth)))))))
adamc@367 501
adamc@369 502 (defun urweb-new-tags ()
adamc@369 503 "Decide if the previous line of XML introduced unclosed tags"
adamc@369 504 (save-excursion
adamc@369 505 (let ((start-pos (point))
adamc@369 506 (depth 0)
adamc@369 507 (done nil))
adamc@369 508 (previous-line 1)
adamc@369 509 (urweb-seek-back)
adamc@369 510 (urweb-skip-matching-braces)
adamc@369 511 (urweb-seek-back)
adamc@369 512 (beginning-of-line)
adamc@369 513 (while (and (not done) (search-forward "<" start-pos t))
adamc@396 514 (cond
adamc@396 515 ((or (looking-at " ") (looking-at "="))
adamc@396 516 nil)
adamc@396 517 ((looking-at "/")
adamc@396 518 (if (re-search-forward "[^\\sw]>" start-pos t)
adamc@369 519 (when (> depth 0) (decf depth))
adamc@396 520 (setq done t)))
adamc@396 521 (t
adamc@396 522 (if (re-search-forward "[^\\sw]>" start-pos t)
adamc@369 523 (if (not (save-excursion (backward-char 2) (looking-at "/")))
adamc@369 524 (incf depth))
adamc@396 525 (setq done t)))))
adamc@369 526 (and (not done) (> depth 0)))))
adamc@369 527
adamc@363 528 (defun urweb-tag-matching-indent ()
adamc@363 529 "Seek back to a matching opener tag and get its line's indent"
adamc@363 530 (save-excursion
adamc@369 531 (end-of-line)
adamc@369 532 (search-backward "</" nil t)
adamc@368 533 (urweb-tag-matcher)
adamc@369 534 (beginning-of-line)
adamc@369 535 (current-indentation)))
adamc@363 536
adamc@373 537 (defconst urweb-sql-main-starters
adamc@1071 538 '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE"))
adamc@373 539
adamc@372 540 (defconst urweb-sql-starters
adamc@373 541 (append urweb-sql-main-starters
adamc@373 542 '("^\\s-+FROM" "WHERE" "GROUP" "ORDER" "HAVING" "LIMIT" "OFFSET"
adamc@373 543 "VALUES" "SET")))
adamc@372 544
adamc@373 545 (defconst urweb-sql-main-starters-re
adamc@373 546 (urweb-syms-re urweb-sql-main-starters))
adamc@372 547 (defconst urweb-sql-starters-re
adamc@372 548 (urweb-syms-re urweb-sql-starters))
adamc@372 549
adamc@374 550 (defconst urweb-sql-main-starters-paren-re
adamc@374 551 (concat "(" urweb-sql-main-starters-re))
adamc@374 552
adamc@374 553 (defun urweb-in-sql ()
adamc@374 554 "Check if the point is in a block of SQL syntax."
adamc@374 555 (save-excursion
adamc@375 556 (let ((start-pos (point))
adamc@375 557 (depth 0)
adamc@375 558 done
adamc@375 559 (good t))
adamc@375 560 (when (re-search-backward urweb-sql-main-starters-paren-re nil t)
adamc@375 561 (forward-char)
adamc@375 562 (while (and (not done) (re-search-forward "[()]" start-pos t))
adamc@375 563 (save-excursion
adamc@375 564 (backward-char)
adamc@375 565 (cond
adamc@375 566 ((looking-at ")")
adamc@375 567 (cond
adamc@375 568 ((= depth 0) (setq done t) (setq good nil))
adamc@375 569 (t (decf depth))))
adamc@375 570 ((looking-at "(")
adamc@375 571 (incf depth)))))
adamc@375 572 good))))
adamc@374 573
adamc@374 574 (defun urweb-sql-depth ()
adamc@374 575 "Check if the point is in a block of SQL syntax.
adamc@374 576 Returns the paren nesting depth if so, and nil otherwise."
adamc@374 577 (save-excursion
adamc@374 578 (let ((depth 0)
adamc@374 579 done)
adamc@374 580 (while (and (not done)
adamc@374 581 (re-search-backward "[()]" nil t))
adamc@374 582 (cond
adamc@374 583 ((looking-at ")")
adamc@374 584 (decf depth))
adamc@374 585 ((looking-at "(")
adamc@374 586 (if (looking-at urweb-sql-main-starters-paren-re)
adamc@374 587 (setq done t)
adamc@374 588 (incf depth)))))
adamc@374 589 (max 0 depth))))
adamc@374 590
adamc@350 591 (defun urweb-calculate-indentation ()
adamc@350 592 (save-excursion
adamc@350 593 (beginning-of-line) (skip-chars-forward "\t ")
adamc@350 594 (urweb-with-ist
adamc@350 595 ;; Indentation for comments alone on a line, matches the
adamc@350 596 ;; proper indentation of the next line.
adamc@350 597 (when (looking-at "(\\*") (urweb-forward-spaces))
adamc@350 598 (let (data
adamc@350 599 (sym (save-excursion (urweb-forward-sym))))
adamc@350 600 (or
adamc@350 601 ;; Allow the user to override the indentation.
adamc@350 602 (when (looking-at (concat ".*" (regexp-quote comment-start)
adamc@350 603 "[ \t]*fixindent[ \t]*"
adamc@350 604 (regexp-quote comment-end)))
adamc@350 605 (current-indentation))
adamc@350 606
adamc@350 607 ;; Continued comment.
adamc@350 608 (and (looking-at "\\*") (urweb-find-comment-indent))
adamc@350 609
adamc@363 610 (and (urweb-in-xml)
adamc@363 611 (let ((prev-indent (save-excursion
adamc@363 612 (previous-line 1)
adamc@369 613 (urweb-seek-back)
adamc@369 614 (urweb-skip-matching-braces)
adamc@369 615 (urweb-seek-back)
adamc@363 616 (current-indentation))))
adamc@363 617 (cond
adamc@363 618 ((looking-at "</")
adamc@363 619 (urweb-tag-matching-indent))
adamc@363 620 ((urweb-new-tags)
adamc@363 621 (+ prev-indent 2))
adamc@363 622 (t
adamc@363 623 prev-indent))))
adamc@363 624
adamc@350 625 ;; Continued string ? (Added 890113 lbn)
adamc@350 626 (and (looking-at "\\\\")
adamc@350 627 (save-excursion
adamc@350 628 (if (save-excursion (previous-line 1)
adamc@350 629 (beginning-of-line)
adamc@350 630 (looking-at "[\t ]*\\\\"))
adamc@350 631 (progn (previous-line 1) (current-indentation))
adamc@350 632 (if (re-search-backward "[^\\\\]\"" nil t)
adamc@350 633 (1+ (current-column))
adamc@350 634 0))))
adamc@350 635
adamc@350 636 ;; Closing parens. Could be handled below with `urweb-indent-relative'?
adamc@350 637 (and (looking-at "\\s)")
adamc@350 638 (save-excursion
adamc@350 639 (skip-syntax-forward ")")
adamc@350 640 (backward-sexp 1)
adamc@350 641 (if (urweb-dangling-sym)
adamc@350 642 (urweb-indent-default 'noindent)
adamc@350 643 (current-column))))
adamc@350 644
adamc@374 645 (and (or (looking-at "FROM") (looking-at urweb-sql-starters-re))
adamc@386 646
adamc@372 647 (save-excursion
adamc@372 648 (and (re-search-backward urweb-sql-starters-re nil t)
adamc@373 649 (if (looking-at urweb-sql-main-starters-re)
adamc@373 650 (current-column)
adamc@373 651 (current-indentation)))))
adamc@372 652
adamc@374 653 (and (urweb-in-sql)
adamc@374 654 (setq data (urweb-sql-depth))
adamc@374 655 (save-excursion
adamc@374 656 (re-search-backward urweb-sql-starters-re nil t)
adamc@374 657 (+ (current-column) 2 (* 2 data))))
adamc@374 658
adamc@350 659 (and (setq data (assoc sym urweb-close-paren))
adamc@350 660 (urweb-indent-relative sym data))
adamc@350 661
adamc@350 662 (and (member sym urweb-starters-syms)
adamc@350 663 (urweb-indent-starter sym))
adamc@350 664
adamc@350 665 (and (string= sym "|") (urweb-indent-pipe))
adamc@350 666
adamc@350 667 (urweb-indent-arg)
adamc@350 668 (urweb-indent-default))))))
adamc@350 669
adamc@350 670 (defsubst urweb-bolp ()
adamc@350 671 (save-excursion (skip-chars-backward " \t|") (bolp)))
adamc@350 672
adamc@350 673 (defun urweb-indent-starter (orig-sym)
adamc@350 674 "Return the indentation to use for a symbol in `urweb-starters-syms'.
adamc@350 675 Point should be just before the symbol ORIG-SYM and is not preserved."
adamc@350 676 (let ((sym (unless (save-excursion (urweb-backward-arg))
adamc@350 677 (urweb-backward-spaces)
adamc@350 678 (urweb-backward-sym))))
adamc@350 679 (if (member sym '(";" "d=")) (setq sym nil))
adamc@350 680 (if sym (urweb-get-sym-indent sym)
adamc@350 681 ;; FIXME: this can take a *long* time !!
adamc@350 682 (setq sym (urweb-find-matching-starter urweb-starters-syms))
adamc@350 683 ;; Don't align with `and' because it might be specially indented.
adamc@350 684 (if (and (or (equal orig-sym "and") (not (equal sym "and")))
adamc@350 685 (urweb-bolp))
adamc@350 686 (+ (current-column)
adamc@350 687 (if (and urweb-rightalign-and (equal orig-sym "and"))
adamc@350 688 (- (length sym) 3) 0))
adamc@350 689 (urweb-indent-starter orig-sym)))))
adamc@350 690
adamc@350 691 (defun urweb-indent-relative (sym data)
adamc@350 692 (save-excursion
adamc@350 693 (urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 694 (unless (second data) (urweb-backward-spaces) (urweb-backward-sym))
adamc@350 695 (+ (or (cdr (assoc sym urweb-symbol-indent)) 0)
adamc@350 696 (urweb-delegated-indent))))
adamc@350 697
adamc@350 698 (defun urweb-indent-pipe ()
adamc@350 699 (let ((sym (urweb-find-matching-starter urweb-pipeheads
adamc@350 700 (urweb-op-prec "|" 'back))))
adamc@350 701 (when sym
adamc@350 702 (if (string= sym "|")
adamc@350 703 (if (urweb-bolp) (current-column) (urweb-indent-pipe))
adamc@350 704 (let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2)))
adamc@350 705 (when (or (member sym '("datatype"))
adamc@350 706 (and (equal sym "and")
adamc@350 707 (save-excursion
adamc@350 708 (forward-word 1)
adamc@350 709 (not (urweb-funname-of-and)))))
adamc@350 710 (re-search-forward "="))
adamc@350 711 (urweb-forward-sym)
adamc@350 712 (urweb-forward-spaces)
adamc@350 713 (+ pipe-indent (current-column)))))))
adamc@350 714
adamc@350 715 (defun urweb-find-forward (re)
adamc@350 716 (urweb-forward-spaces)
adamc@350 717 (while (and (not (looking-at re))
adamc@350 718 (progn
adamc@350 719 (or (ignore-errors (forward-sexp 1) t) (forward-char 1))
adamc@350 720 (urweb-forward-spaces)
adamc@350 721 (not (looking-at re))))))
adamc@350 722
adamc@350 723 (defun urweb-indent-arg ()
adamc@350 724 (and (save-excursion (ignore-errors (urweb-forward-arg)))
adamc@350 725 ;;(not (looking-at urweb-not-arg-re))
adamc@350 726 ;; looks like a function or an argument
adamc@350 727 (urweb-move-if (urweb-backward-arg))
adamc@350 728 ;; an argument
adamc@350 729 (if (save-excursion (not (urweb-backward-arg)))
adamc@350 730 ;; a first argument
adamc@350 731 (+ (current-column) urweb-indent-args)
adamc@350 732 ;; not a first arg
adamc@350 733 (while (and (/= (current-column) (current-indentation))
adamc@350 734 (urweb-move-if (urweb-backward-arg))))
adamc@350 735 (unless (save-excursion (urweb-backward-arg))
adamc@350 736 ;; all earlier args are on the same line
adamc@350 737 (urweb-forward-arg) (urweb-forward-spaces))
adamc@350 738 (current-column))))
adamc@350 739
adamc@350 740 (defun urweb-get-indent (data sym)
adamc@350 741 (let (d)
adamc@350 742 (cond
adamc@350 743 ((not (listp data)) data)
adamc@350 744 ((setq d (member sym data)) (cadr d))
adamc@350 745 ((and (consp data) (not (stringp (car data)))) (car data))
adamc@350 746 (t urweb-indent-level))))
adamc@350 747
adamc@350 748 (defun urweb-dangling-sym ()
adamc@350 749 "Non-nil if the symbol after point is dangling.
adamc@350 750 The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that
adamc@350 751 it is not on its own line but is the last element on that line."
adamc@350 752 (save-excursion
adamc@350 753 (and (not (urweb-bolp))
adamc@350 754 (< (urweb-point-after (end-of-line))
adamc@350 755 (urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "("))
adamc@350 756 (urweb-forward-spaces))))))
adamc@350 757
adamc@350 758 (defun urweb-delegated-indent ()
adamc@350 759 (if (urweb-dangling-sym)
adamc@350 760 (urweb-indent-default 'noindent)
adamc@350 761 (urweb-move-if (backward-word 1)
adamc@350 762 (looking-at urweb-agglomerate-re))
adamc@350 763 (current-column)))
adamc@350 764
adamc@350 765 (defun urweb-get-sym-indent (sym &optional style)
adamc@350 766 "Find the indentation for the SYM we're `looking-at'.
adamc@350 767 If indentation is delegated, point will move to the start of the parent.
adamc@350 768 Optional argument STYLE is currently ignored."
adamc@371 769 ;;(assert (equal sym (save-excursion (urweb-forward-sym))))
adamc@350 770 (save-excursion
adamc@350 771 (let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren)))
adamc@350 772 (head-sym sym))
adamc@350 773 (when (and delegate (not (eval (third delegate))))
adamc@350 774 ;;(urweb-find-match-backward sym delegate)
adamc@350 775 (urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 776 (setq head-sym
adamc@350 777 (if (second delegate)
adamc@350 778 (save-excursion (urweb-forward-sym))
adamc@350 779 (urweb-backward-spaces) (urweb-backward-sym))))
adamc@350 780 (let ((idata (assoc head-sym urweb-indent-rule)))
adamc@350 781 (when idata
adamc@350 782 ;;(if (or style (not delegate))
adamc@350 783 ;; normal indentation
adamc@350 784 (let ((indent (urweb-get-indent (cdr idata) sym)))
adamc@350 785 (when indent (+ (urweb-delegated-indent) indent)))
adamc@350 786 ;; delgate indentation to the parent
adamc@350 787 ;;(urweb-forward-sym) (urweb-backward-sexp nil)
adamc@350 788 ;;(let* ((parent-sym (save-excursion (urweb-forward-sym)))
adamc@350 789 ;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters))))
adamc@350 790 ;; check the special rules
adamc@350 791 ;;(+ (urweb-delegated-indent)
adamc@350 792 ;; (or (urweb-get-indent (cdr indent-data) 1 'strict)
adamc@350 793 ;; (urweb-get-indent (cdr parent-indent) 1 'strict)
adamc@350 794 ;; (urweb-get-indent (cdr indent-data) 0)
adamc@350 795 ;; (urweb-get-indent (cdr parent-indent) 0))))))))
adamc@350 796 )))))
adamc@350 797
adamc@350 798 (defun urweb-indent-default (&optional noindent)
adamc@386 799 (condition-case nil
adamc@386 800 (progn
adamc@386 801 (let* ((sym-after (save-excursion (urweb-forward-sym)))
adamc@386 802 (_ (urweb-backward-spaces))
adamc@386 803 (sym-before (urweb-backward-sym))
adamc@386 804 (sym-indent (and sym-before (urweb-get-sym-indent sym-before)))
adamc@386 805 (indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0)))
adamc@386 806 (when (equal sym-before "end")
adamc@386 807 ;; I don't understand what's really happening here, but when
adamc@386 808 ;; it's `end' clearly, we need to do something special.
adamc@386 809 (forward-word 1)
adamc@386 810 (setq sym-before nil sym-indent nil))
adamc@386 811 (cond
adamc@386 812 (sym-indent
adamc@386 813 ;; the previous sym is an indentation introducer: follow the rule
adamc@386 814 (if noindent
adamc@386 815 ;;(current-column)
adamc@386 816 sym-indent
adamc@386 817 (+ sym-indent indent-after)))
adamc@386 818 ;; If we're just after a hanging open paren.
adamc@386 819 ((and (eq (char-syntax (preceding-char)) ?\()
adamc@386 820 (save-excursion (backward-char) (urweb-dangling-sym)))
adamc@386 821 (backward-char)
adamc@386 822 (urweb-indent-default))
adamc@386 823 (t
adamc@386 824 ;; default-default
adamc@386 825 (let* ((prec-after (urweb-op-prec sym-after 'back))
adamc@386 826 (prec (or (urweb-op-prec sym-before 'back) prec-after 100)))
adamc@386 827 ;; go back until you hit a symbol that has a lower prec than the
adamc@386 828 ;; "current one", or until you backed over a sym that has the same prec
adamc@386 829 ;; but is at the beginning of a line.
adamc@386 830 (while (and (not (urweb-bolp))
adamc@386 831 (while (urweb-move-if (urweb-backward-sexp (1- prec))))
adamc@386 832 (not (urweb-bolp)))
adamc@386 833 (while (urweb-move-if (urweb-backward-sexp prec))))
adamc@386 834 (if noindent
adamc@386 835 ;; the `noindent' case does back over an introductory symbol
adamc@386 836 ;; such as `fun', ...
adamc@386 837 (progn
adamc@386 838 (urweb-move-if
adamc@386 839 (urweb-backward-spaces)
adamc@386 840 (member (urweb-backward-sym) urweb-starters-syms))
adamc@386 841 (current-column))
adamc@386 842 ;; Use `indent-after' for cases such as when , or ; should be
adamc@386 843 ;; outdented so that their following terms are aligned.
adamc@386 844 (+ (if (progn
adamc@386 845 (if (equal sym-after ";")
adamc@386 846 (urweb-move-if
adamc@386 847 (urweb-backward-spaces)
adamc@386 848 (member (urweb-backward-sym) urweb-starters-syms)))
adamc@386 849 (and sym-after (not (looking-at sym-after))))
adamc@386 850 indent-after 0)
adamc@386 851 (current-column))))))))
adamc@386 852 (error 0)))
adamc@350 853
adamc@350 854
adamc@350 855 ;; maybe `|' should be set to word-syntax in our temp syntax table ?
adamc@350 856 (defun urweb-current-indentation ()
adamc@350 857 (save-excursion
adamc@350 858 (beginning-of-line)
adamc@350 859 (skip-chars-forward " \t|")
adamc@350 860 (current-column)))
adamc@350 861
adamc@350 862
adamc@350 863 (defun urweb-find-matching-starter (syms &optional prec)
adamc@350 864 (let (sym)
adamc@350 865 (ignore-errors
adamc@350 866 (while
adamc@350 867 (progn (urweb-backward-sexp prec)
adamc@350 868 (setq sym (save-excursion (urweb-forward-sym)))
adamc@350 869 (not (or (member sym syms) (bobp)))))
adamc@350 870 (if (member sym syms) sym))))
adamc@350 871
adamc@350 872 (defun urweb-skip-siblings ()
adamc@350 873 (while (and (not (bobp)) (urweb-backward-arg))
adamc@350 874 (urweb-find-matching-starter urweb-starters-syms)))
adamc@350 875
adamc@350 876 (defun urweb-beginning-of-defun ()
adamc@350 877 (let ((sym (urweb-find-matching-starter urweb-starters-syms)))
adamc@350 878 (if (member sym '("fun" "and" "functor" "signature" "structure"
adamc@350 879 "datatype"))
adamc@350 880 (save-excursion (urweb-forward-sym) (urweb-forward-spaces)
adamc@350 881 (urweb-forward-sym))
adamc@350 882 ;; We're inside a "non function declaration": let's skip all other
adamc@350 883 ;; declarations that we find at the same level and try again.
adamc@350 884 (urweb-skip-siblings)
adamc@350 885 ;; Obviously, let's not try again if we're at bobp.
adamc@350 886 (unless (bobp) (urweb-beginning-of-defun)))))
adamc@350 887
adamc@350 888 (defcustom urweb-max-name-components 3
adamc@350 889 "Maximum number of components to use for the current function name."
adamc@350 890 :group 'urweb
adamc@350 891 :type 'integer)
adamc@350 892
adamc@350 893 (defun urweb-current-fun-name ()
adamc@350 894 (save-excursion
adamc@350 895 (let ((count urweb-max-name-components)
adamc@350 896 fullname name)
adamc@350 897 (end-of-line)
adamc@350 898 (while (and (> count 0)
adamc@350 899 (setq name (urweb-beginning-of-defun)))
adamc@350 900 (decf count)
adamc@350 901 (setq fullname (if fullname (concat name "." fullname) name))
adamc@350 902 ;; Skip all other declarations that we find at the same level.
adamc@350 903 (urweb-skip-siblings))
adamc@350 904 fullname)))
adamc@350 905
adamc@358 906
adamc@358 907
adamc@350 908 (provide 'urweb-mode)
adamc@350 909
adamc@350 910 ;;; urweb-mode.el ends here