Mercurial > urweb

annotate src/elisp/urweb-mode.el @ 2162:c39c48696393

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