adamc@350: ;;; urweb-mode.el --- Major mode for editing (Standard) ML adamc@350: adamc@350: ;; Based on sml-mode: adamc@350: ;; Copyright (C) 1999,2000,2004 Stefan Monnier adamc@350: ;; Copyright (C) 1994-1997 Matthew J. Morley adamc@350: ;; Copyright (C) 1989 Lars Bo Nielsen adamc@350: ;; adamc@350: ;; Modified for urweb-mode: adamc@350: ;; Copyright (C) 2008 Adam Chlipala adamc@350: adamc@350: ;; Author: Lars Bo Nielsen adamc@350: ;; Olin Shivers adamc@350: ;; Fritz Knabe (?) adamc@350: ;; Steven Gilmore (?) adamc@350: ;; Matthew Morley (aka ) adamc@350: ;; Matthias Blume (aka ) adamc@350: ;; (Stefan Monnier) monnier@cs.yale.edu adamc@350: ;; Adam Chlipala adamc@350: adamc@350: ;; This file is not part of GNU Emacs, but it is distributed under the adamc@350: ;; same conditions. adamc@350: adamc@350: ;; This program is free software; you can redistribute it and/or adamc@350: ;; modify it under the terms of the GNU General Public License as adamc@350: ;; published by the Free Software Foundation; either version 2, or (at adamc@350: ;; your option) any later version. adamc@350: adamc@350: ;; This program is distributed in the hope that it will be useful, but adamc@350: ;; WITHOUT ANY WARRANTY; without even the implied warranty of adamc@350: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU adamc@350: ;; General Public License for more details. adamc@350: adamc@350: ;; You should have received a copy of the GNU General Public License adamc@350: ;; along with GNU Emacs; see the file COPYING. If not, write to the adamc@350: ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. adamc@350: adamc@350: ;;; Commentary: adamc@350: adamc@350: ;;; HISTORY adamc@350: adamc@350: ;; Still under construction: History obscure, needs a biographer as adamc@350: ;; well as a M-x doctor. Change Log on request. adamc@350: adamc@350: ;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's urweb.el. adamc@350: adamc@350: ;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and adamc@350: ;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus, adamc@350: ;; and numerous bugs and bug-fixes. adamc@350: adamc@350: ;;; DESCRIPTION adamc@350: adamc@350: ;; See accompanying info file: urweb-mode.info adamc@350: adamc@350: ;;; FOR YOUR .EMACS FILE adamc@350: adamc@350: ;; If urweb-mode.el lives in some non-standard directory, you must tell adamc@350: ;; emacs where to get it. This may or may not be necessary: adamc@350: adamc@350: ;; (add-to-list 'load-path "~jones/lib/emacs/") adamc@350: adamc@350: ;; Then to access the commands autoload urweb-mode with that command: adamc@350: adamc@350: ;; (load "urweb-mode-startup") adamc@350: adamc@350: ;; urweb-mode-hook is run whenever a new urweb-mode buffer is created. adamc@350: adamc@350: ;;; Code: adamc@350: adamc@350: (eval-when-compile (require 'cl)) adamc@350: (require 'urweb-util) adamc@350: (require 'urweb-move) adamc@350: (require 'urweb-defs) adamc@350: (condition-case nil (require 'skeleton) (error nil)) adamc@350: adamc@350: ;;; VARIABLES CONTROLLING INDENTATION adamc@350: adamc@350: (defcustom urweb-indent-level 4 adamc@350: "*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')." adamc@350: :group 'urweb adamc@350: :type '(integer)) adamc@350: adamc@350: (defcustom urweb-indent-args urweb-indent-level adamc@350: "*Indentation of args placed on a separate line." adamc@350: :group 'urweb adamc@350: :type '(integer)) adamc@350: adamc@350: (defcustom urweb-electric-semi-mode nil adamc@350: "*If non-nil, `\;' will self insert, reindent the line, and do a newline. adamc@350: If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)." adamc@350: :group 'urweb adamc@350: :type 'boolean) adamc@350: adamc@350: (defcustom urweb-rightalign-and t adamc@350: "If non-nil, right-align `and' with its leader. adamc@350: If nil: If t: adamc@350: datatype a = A datatype a = A adamc@350: and b = B and b = B" adamc@350: :group 'urweb adamc@350: :type 'boolean) adamc@350: adamc@350: ;;; OTHER GENERIC MODE VARIABLES adamc@350: adamc@350: (defvar urweb-mode-info "urweb-mode" adamc@350: "*Where to find Info file for `urweb-mode'. adamc@350: The default assumes the info file \"urweb-mode.info\" is on Emacs' info adamc@350: directory path. If it is not, either put the file on the standard path adamc@350: or set the variable `urweb-mode-info' to the exact location of this file adamc@350: adamc@350: (setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\") adamc@350: adamc@350: in your .emacs file. You can always set it interactively with the adamc@350: set-variable command.") adamc@350: adamc@350: (defvar urweb-mode-hook nil adamc@350: "*Run upon entering `urweb-mode'. adamc@350: This is a good place to put your preferred key bindings.") adamc@350: adamc@350: ;;; CODE FOR Ur/Web-MODE adamc@350: adamc@350: (defun urweb-mode-info () adamc@350: "Command to access the TeXinfo documentation for `urweb-mode'. adamc@350: See doc for the variable `urweb-mode-info'." adamc@350: (interactive) adamc@350: (require 'info) adamc@350: (condition-case nil adamc@350: (info urweb-mode-info) adamc@350: (error (progn adamc@350: (describe-variable 'urweb-mode-info) adamc@350: (message "Can't find it... set this variable first!"))))) adamc@350: adamc@350: adamc@350: ;; font-lock setup adamc@350: adamc@350: (defconst urweb-keywords-regexp adamc@350: (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints" adamc@350: "datatype" "else" "end" "extern" "fn" "fold" adamc@350: "fun" "functor" "if" "include" adamc@350: "of" "open" adamc@350: "rec" "sequence" "sig" "signature" adamc@350: "struct" "structure" "table" "then" "type" "val" "where" adamc@350: "with" adamc@350: adamc@350: "Name" "Type" "Unit") adamc@350: "A regexp that matches any non-SQL keywords of Ur/Web.") adamc@350: adamc@350: (defconst urweb-sql-keywords-regexp adamc@350: (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" adamc@350: "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT" adamc@350: "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX" adamc@350: "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE") adamc@350: "A regexp that matches SQL keywords.") adamc@350: adamc@351: (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>" adamc@351: "A regexp that matches lowercase Ur/Web identifiers.") adamc@351: adamc@351: (defconst urweb-cident-regexp "\\<[A-Z][A-Za-z0-9_']*\\>" adamc@351: "A regexp that matches uppercase Ur/Web identifiers.") adamc@351: adamc@350: ;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; adamc@350: adamc@350: ;; The font lock regular expressions. adamc@350: adamc@350: (defconst urweb-font-lock-keywords adamc@350: `(;;(urweb-font-comments-and-strings) adamc@350: (,(concat "\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]") adamc@350: (1 font-lock-keyword-face) adamc@350: (6 font-lock-function-name-face)) adamc@350: (,(concat "\\<\\(\\(data\\)?type\\|con\\)\\s-+\\(\\sw+\\)") adamc@350: (1 font-lock-keyword-face) adamc@350: (7 font-lock-type-def-face)) adamc@350: ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" adamc@350: (1 font-lock-keyword-face) adamc@350: (3 font-lock-variable-name-face)) adamc@350: ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" adamc@350: (1 font-lock-keyword-face) adamc@350: (2 font-lock-module-def-face)) adamc@350: ("\\<\\(signature\\)\\s-+\\(\\sw+\\)" adamc@350: (1 font-lock-keyword-face) adamc@350: (2 font-lock-interface-def-face)) adamc@350: adamc@350: (,urweb-keywords-regexp . font-lock-keyword-face) adamc@351: (,urweb-sql-keywords-regexp . font-lock-sql-face) adamc@351: ; (,urweb-lident-regexp . font-lock-variable-face) adamc@351: (,urweb-cident-regexp . font-lock-cvariable-face)) adamc@350: "Regexps matching standard Ur/Web keywords.") adamc@350: adamc@350: (defface font-lock-type-def-face adamc@350: '((t (:bold t))) adamc@350: "Font Lock mode face used to highlight type definitions." adamc@350: :group 'font-lock-highlighting-faces) adamc@350: (defvar font-lock-type-def-face 'font-lock-type-def-face adamc@350: "Face name to use for type definitions.") adamc@350: adamc@350: (defface font-lock-module-def-face adamc@350: '((t (:bold t))) adamc@350: "Font Lock mode face used to highlight module definitions." adamc@350: :group 'font-lock-highlighting-faces) adamc@350: (defvar font-lock-module-def-face 'font-lock-module-def-face adamc@350: "Face name to use for module definitions.") adamc@350: adamc@350: (defface font-lock-interface-def-face adamc@350: '((t (:bold t))) adamc@350: "Font Lock mode face used to highlight interface definitions." adamc@350: :group 'font-lock-highlighting-faces) adamc@350: (defvar font-lock-interface-def-face 'font-lock-interface-def-face adamc@350: "Face name to use for interface definitions.") adamc@350: adamc@350: (defface font-lock-sql-face adamc@350: '((t (:bold t))) adamc@350: "Font Lock mode face used to highlight SQL keywords." adamc@350: :group 'font-lock-highlighting-faces) adamc@350: (defvar font-lock-sql-face 'font-lock-sql-face adamc@350: "Face name to use for SQL keywords.") adamc@350: adamc@351: ;(defface font-lock-variable-face adamc@351: ; '((t (:foreground "green"))) adamc@351: ; "Font Lock mode face used to highlight lowercase identifiers." adamc@351: ; :group 'font-lock-highlighting-faces) adamc@351: ;(defvar font-lock-variable-face 'font-lock-variable-face adamc@351: ; "Face name to use for lowercase identifiers.") adamc@351: adamc@351: (defface font-lock-cvariable-face adamc@351: '((t (:foreground "dark blue"))) adamc@351: "Font Lock mode face used to highlight capitalized identifiers." adamc@351: :group 'font-lock-highlighting-faces) adamc@351: (defvar font-lock-cvariable-face 'font-lock-cvariable-face adamc@351: "Face name to use for capitalized identifiers.") adamc@351: adamc@350: ;; adamc@350: ;; Code to handle nested comments and unusual string escape sequences adamc@350: ;; adamc@350: adamc@350: (defsyntax urweb-syntax-prop-table adamc@350: '((?\\ . ".") (?* . ".")) adamc@350: "Syntax table for text-properties") adamc@350: adamc@350: ;; For Emacsen that have no built-in support for nested comments adamc@350: (defun urweb-get-depth-st () adamc@350: (save-excursion adamc@350: (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil)) adamc@350: (_ (backward-char)) adamc@350: (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp)) adamc@350: (pt (point))) adamc@350: (when disp adamc@350: (let* ((depth adamc@350: (save-match-data adamc@350: (if (re-search-backward "\\*)\\|(\\*" nil t) adamc@350: (+ (or (get-char-property (point) 'comment-depth) 0) adamc@350: (case (char-after) (?\( 1) (?* 0)) adamc@350: disp) adamc@350: 0))) adamc@350: (depth (if (> depth 0) depth))) adamc@350: (put-text-property pt (1+ pt) 'comment-depth depth) adamc@350: (when depth urweb-syntax-prop-table)))))) adamc@350: adamc@350: (defconst urweb-font-lock-syntactic-keywords adamc@350: `(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table)) adamc@350: ,@(unless urweb-builtin-nested-comments-flag adamc@350: '(("(?\\(\\*\\))?" (1 (urweb-get-depth-st))))))) adamc@350: adamc@350: (defconst urweb-font-lock-defaults adamc@350: '(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil adamc@350: (font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords))) adamc@350: adamc@350: ;;;; adamc@350: ;;;; Imenu support adamc@350: ;;;; adamc@350: adamc@350: (defvar urweb-imenu-regexp adamc@350: (concat "^[ \t]*\\(let[ \t]+\\)?" adamc@350: (regexp-opt (append urweb-module-head-syms adamc@350: '("and" "fun" "datatype" "type")) t) adamc@350: "\\>")) adamc@350: adamc@350: (defun urweb-imenu-create-index () adamc@350: (let (alist) adamc@350: (goto-char (point-max)) adamc@350: (while (re-search-backward urweb-imenu-regexp nil t) adamc@350: (save-excursion adamc@350: (let ((kind (match-string 2)) adamc@350: (column (progn (goto-char (match-beginning 2)) (current-column))) adamc@350: (location adamc@350: (progn (goto-char (match-end 0)) adamc@350: (urweb-forward-spaces) adamc@350: (when (looking-at urweb-tyvarseq-re) adamc@350: (goto-char (match-end 0))) adamc@350: (point))) adamc@350: (name (urweb-forward-sym))) adamc@350: ;; Eliminate trivial renamings. adamc@350: (when (or (not (member kind '("structure" "signature"))) adamc@350: (progn (search-forward "=") adamc@350: (urweb-forward-spaces) adamc@350: (looking-at "sig\\|struct"))) adamc@350: (push (cons (concat (make-string (/ column 2) ?\ ) name) location) adamc@350: alist))))) adamc@350: alist)) adamc@350: adamc@350: ;;; MORE CODE FOR URWEB-MODE adamc@350: adamc@350: ;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name)) adamc@350: ;;;###autoload adamc@350: (add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . urweb-mode)) adamc@350: adamc@350: ;;;###autoload adamc@350: (define-derived-mode urweb-mode fundamental-mode "Ur/Web" adamc@350: "\\Major mode for editing Ur/Web code. adamc@350: This mode runs `urweb-mode-hook' just before exiting. adamc@350: \\{urweb-mode-map}" adamc@350: (set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults) adamc@350: (set (make-local-variable 'outline-regexp) urweb-outline-regexp) adamc@350: (set (make-local-variable 'imenu-create-index-function) adamc@350: 'urweb-imenu-create-index) adamc@350: (set (make-local-variable 'add-log-current-defun-function) adamc@350: 'urweb-current-fun-name) adamc@350: ;; Treat paragraph-separators in comments as paragraph-separators. adamc@350: (set (make-local-variable 'paragraph-separate) adamc@350: (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)")) adamc@350: (set (make-local-variable 'require-final-newline) t) adamc@350: ;; forward-sexp-function is an experimental variable in my hacked Emacs. adamc@350: (set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp) adamc@350: ;; For XEmacs adamc@350: (easy-menu-add urweb-mode-menu) adamc@350: ;; Compatibility. FIXME: we should use `-' in Emacs-CVS. adamc@350: (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil)) adamc@350: (urweb-mode-variables)) adamc@350: adamc@350: (defun urweb-mode-variables () adamc@350: (set-syntax-table urweb-mode-syntax-table) adamc@350: (setq local-abbrev-table urweb-mode-abbrev-table) adamc@350: ;; A paragraph is separated by blank lines or ^L only. adamc@350: adamc@350: (set (make-local-variable 'indent-line-function) 'urweb-indent-line) adamc@350: (set (make-local-variable 'comment-start) "(* ") adamc@350: (set (make-local-variable 'comment-end) " *)") adamc@350: (set (make-local-variable 'comment-nested) t) adamc@350: ;;(set (make-local-variable 'block-comment-start) "* ") adamc@350: ;;(set (make-local-variable 'block-comment-end) "") adamc@350: ;; (set (make-local-variable 'comment-column) 40) adamc@350: (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")) adamc@350: adamc@350: (defun urweb-funname-of-and () adamc@350: "Name of the function this `and' defines, or nil if not a function. adamc@350: Point has to be right after the `and' symbol and is not preserved." adamc@350: (urweb-forward-spaces) adamc@350: (if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0))) adamc@350: (let ((sym (urweb-forward-sym))) adamc@350: (urweb-forward-spaces) adamc@350: (unless (or (member sym '(nil "d=")) adamc@350: (member (urweb-forward-sym) '("d="))) adamc@350: sym))) adamc@350: adamc@350: ;;; INDENTATION !!! adamc@350: adamc@350: (defun urweb-mark-function () adamc@350: "Synonym for `mark-paragraph' -- sorry. adamc@350: If anyone has a good algorithm for this..." adamc@350: (interactive) adamc@350: (mark-paragraph)) adamc@350: adamc@350: (defun urweb-indent-line () adamc@350: "Indent current line of Ur/Web code." adamc@350: (interactive) adamc@350: (let ((savep (> (current-column) (current-indentation))) adamc@350: (indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0))) adamc@350: (if savep adamc@350: (save-excursion (indent-line-to indent)) adamc@350: (indent-line-to indent)))) adamc@350: adamc@350: (defun urweb-back-to-outer-indent () adamc@350: "Unindents to the next outer level of indentation." adamc@350: (interactive) adamc@350: (save-excursion adamc@350: (beginning-of-line) adamc@350: (skip-chars-forward "\t ") adamc@350: (let ((start-column (current-column)) adamc@350: (indent (current-column))) adamc@350: (if (> start-column 0) adamc@350: (progn adamc@350: (save-excursion adamc@350: (while (>= indent start-column) adamc@350: (if (re-search-backward "^[^\n]" nil t) adamc@350: (setq indent (current-indentation)) adamc@350: (setq indent 0)))) adamc@350: (backward-delete-char-untabify (- start-column indent))))))) adamc@350: adamc@350: (defun urweb-find-comment-indent () adamc@350: (save-excursion adamc@350: (let ((depth 1)) adamc@350: (while (> depth 0) adamc@350: (if (re-search-backward "(\\*\\|\\*)" nil t) adamc@350: (cond adamc@350: ;; FIXME: That's just a stop-gap. adamc@350: ((eq (get-text-property (point) 'face) 'font-lock-string-face)) adamc@350: ((looking-at "*)") (incf depth)) adamc@350: ((looking-at comment-start-skip) (decf depth))) adamc@350: (setq depth -1))) adamc@350: (if (= depth 0) adamc@350: (1+ (current-column)) adamc@350: nil)))) adamc@350: adamc@350: (defun urweb-calculate-indentation () adamc@350: (save-excursion adamc@350: (beginning-of-line) (skip-chars-forward "\t ") adamc@350: (urweb-with-ist adamc@350: ;; Indentation for comments alone on a line, matches the adamc@350: ;; proper indentation of the next line. adamc@350: (when (looking-at "(\\*") (urweb-forward-spaces)) adamc@350: (let (data adamc@350: (sym (save-excursion (urweb-forward-sym)))) adamc@350: (or adamc@350: ;; Allow the user to override the indentation. adamc@350: (when (looking-at (concat ".*" (regexp-quote comment-start) adamc@350: "[ \t]*fixindent[ \t]*" adamc@350: (regexp-quote comment-end))) adamc@350: (current-indentation)) adamc@350: adamc@350: ;; Continued comment. adamc@350: (and (looking-at "\\*") (urweb-find-comment-indent)) adamc@350: adamc@350: ;; Continued string ? (Added 890113 lbn) adamc@350: (and (looking-at "\\\\") adamc@350: (save-excursion adamc@350: (if (save-excursion (previous-line 1) adamc@350: (beginning-of-line) adamc@350: (looking-at "[\t ]*\\\\")) adamc@350: (progn (previous-line 1) (current-indentation)) adamc@350: (if (re-search-backward "[^\\\\]\"" nil t) adamc@350: (1+ (current-column)) adamc@350: 0)))) adamc@350: adamc@350: ;; Closing parens. Could be handled below with `urweb-indent-relative'? adamc@350: (and (looking-at "\\s)") adamc@350: (save-excursion adamc@350: (skip-syntax-forward ")") adamc@350: (backward-sexp 1) adamc@350: (if (urweb-dangling-sym) adamc@350: (urweb-indent-default 'noindent) adamc@350: (current-column)))) adamc@350: adamc@350: (and (setq data (assoc sym urweb-close-paren)) adamc@350: (urweb-indent-relative sym data)) adamc@350: adamc@350: (and (member sym urweb-starters-syms) adamc@350: (urweb-indent-starter sym)) adamc@350: adamc@350: (and (string= sym "|") (urweb-indent-pipe)) adamc@350: adamc@350: (urweb-indent-arg) adamc@350: (urweb-indent-default)))))) adamc@350: adamc@350: (defsubst urweb-bolp () adamc@350: (save-excursion (skip-chars-backward " \t|") (bolp))) adamc@350: adamc@350: (defun urweb-indent-starter (orig-sym) adamc@350: "Return the indentation to use for a symbol in `urweb-starters-syms'. adamc@350: Point should be just before the symbol ORIG-SYM and is not preserved." adamc@350: (let ((sym (unless (save-excursion (urweb-backward-arg)) adamc@350: (urweb-backward-spaces) adamc@350: (urweb-backward-sym)))) adamc@350: (if (member sym '(";" "d=")) (setq sym nil)) adamc@350: (if sym (urweb-get-sym-indent sym) adamc@350: ;; FIXME: this can take a *long* time !! adamc@350: (setq sym (urweb-find-matching-starter urweb-starters-syms)) adamc@350: ;; Don't align with `and' because it might be specially indented. adamc@350: (if (and (or (equal orig-sym "and") (not (equal sym "and"))) adamc@350: (urweb-bolp)) adamc@350: (+ (current-column) adamc@350: (if (and urweb-rightalign-and (equal orig-sym "and")) adamc@350: (- (length sym) 3) 0)) adamc@350: (urweb-indent-starter orig-sym))))) adamc@350: adamc@350: (defun urweb-indent-relative (sym data) adamc@350: (save-excursion adamc@350: (urweb-forward-sym) (urweb-backward-sexp nil) adamc@350: (unless (second data) (urweb-backward-spaces) (urweb-backward-sym)) adamc@350: (+ (or (cdr (assoc sym urweb-symbol-indent)) 0) adamc@350: (urweb-delegated-indent)))) adamc@350: adamc@350: (defun urweb-indent-pipe () adamc@350: (let ((sym (urweb-find-matching-starter urweb-pipeheads adamc@350: (urweb-op-prec "|" 'back)))) adamc@350: (when sym adamc@350: (if (string= sym "|") adamc@350: (if (urweb-bolp) (current-column) (urweb-indent-pipe)) adamc@350: (let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2))) adamc@350: (when (or (member sym '("datatype")) adamc@350: (and (equal sym "and") adamc@350: (save-excursion adamc@350: (forward-word 1) adamc@350: (not (urweb-funname-of-and))))) adamc@350: (re-search-forward "=")) adamc@350: (urweb-forward-sym) adamc@350: (urweb-forward-spaces) adamc@350: (+ pipe-indent (current-column))))))) adamc@350: adamc@350: (defun urweb-find-forward (re) adamc@350: (urweb-forward-spaces) adamc@350: (while (and (not (looking-at re)) adamc@350: (progn adamc@350: (or (ignore-errors (forward-sexp 1) t) (forward-char 1)) adamc@350: (urweb-forward-spaces) adamc@350: (not (looking-at re)))))) adamc@350: adamc@350: (defun urweb-indent-arg () adamc@350: (and (save-excursion (ignore-errors (urweb-forward-arg))) adamc@350: ;;(not (looking-at urweb-not-arg-re)) adamc@350: ;; looks like a function or an argument adamc@350: (urweb-move-if (urweb-backward-arg)) adamc@350: ;; an argument adamc@350: (if (save-excursion (not (urweb-backward-arg))) adamc@350: ;; a first argument adamc@350: (+ (current-column) urweb-indent-args) adamc@350: ;; not a first arg adamc@350: (while (and (/= (current-column) (current-indentation)) adamc@350: (urweb-move-if (urweb-backward-arg)))) adamc@350: (unless (save-excursion (urweb-backward-arg)) adamc@350: ;; all earlier args are on the same line adamc@350: (urweb-forward-arg) (urweb-forward-spaces)) adamc@350: (current-column)))) adamc@350: adamc@350: (defun urweb-get-indent (data sym) adamc@350: (let (d) adamc@350: (cond adamc@350: ((not (listp data)) data) adamc@350: ((setq d (member sym data)) (cadr d)) adamc@350: ((and (consp data) (not (stringp (car data)))) (car data)) adamc@350: (t urweb-indent-level)))) adamc@350: adamc@350: (defun urweb-dangling-sym () adamc@350: "Non-nil if the symbol after point is dangling. adamc@350: The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that adamc@350: it is not on its own line but is the last element on that line." adamc@350: (save-excursion adamc@350: (and (not (urweb-bolp)) adamc@350: (< (urweb-point-after (end-of-line)) adamc@350: (urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "(")) adamc@350: (urweb-forward-spaces)))))) adamc@350: adamc@350: (defun urweb-delegated-indent () adamc@350: (if (urweb-dangling-sym) adamc@350: (urweb-indent-default 'noindent) adamc@350: (urweb-move-if (backward-word 1) adamc@350: (looking-at urweb-agglomerate-re)) adamc@350: (current-column))) adamc@350: adamc@350: (defun urweb-get-sym-indent (sym &optional style) adamc@350: "Find the indentation for the SYM we're `looking-at'. adamc@350: If indentation is delegated, point will move to the start of the parent. adamc@350: Optional argument STYLE is currently ignored." adamc@350: (assert (equal sym (save-excursion (urweb-forward-sym)))) adamc@350: (save-excursion adamc@350: (let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren))) adamc@350: (head-sym sym)) adamc@350: (when (and delegate (not (eval (third delegate)))) adamc@350: ;;(urweb-find-match-backward sym delegate) adamc@350: (urweb-forward-sym) (urweb-backward-sexp nil) adamc@350: (setq head-sym adamc@350: (if (second delegate) adamc@350: (save-excursion (urweb-forward-sym)) adamc@350: (urweb-backward-spaces) (urweb-backward-sym)))) adamc@350: adamc@350: (let ((idata (assoc head-sym urweb-indent-rule))) adamc@350: (when idata adamc@350: ;;(if (or style (not delegate)) adamc@350: ;; normal indentation adamc@350: (let ((indent (urweb-get-indent (cdr idata) sym))) adamc@350: (when indent (+ (urweb-delegated-indent) indent))) adamc@350: ;; delgate indentation to the parent adamc@350: ;;(urweb-forward-sym) (urweb-backward-sexp nil) adamc@350: ;;(let* ((parent-sym (save-excursion (urweb-forward-sym))) adamc@350: ;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters)))) adamc@350: ;; check the special rules adamc@350: ;;(+ (urweb-delegated-indent) adamc@350: ;; (or (urweb-get-indent (cdr indent-data) 1 'strict) adamc@350: ;; (urweb-get-indent (cdr parent-indent) 1 'strict) adamc@350: ;; (urweb-get-indent (cdr indent-data) 0) adamc@350: ;; (urweb-get-indent (cdr parent-indent) 0)))))))) adamc@350: ))))) adamc@350: adamc@350: (defun urweb-indent-default (&optional noindent) adamc@350: (let* ((sym-after (save-excursion (urweb-forward-sym))) adamc@350: (_ (urweb-backward-spaces)) adamc@350: (sym-before (urweb-backward-sym)) adamc@350: (sym-indent (and sym-before (urweb-get-sym-indent sym-before))) adamc@350: (indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0))) adamc@350: (when (equal sym-before "end") adamc@350: ;; I don't understand what's really happening here, but when adamc@350: ;; it's `end' clearly, we need to do something special. adamc@350: (forward-word 1) adamc@350: (setq sym-before nil sym-indent nil)) adamc@350: (cond adamc@350: (sym-indent adamc@350: ;; the previous sym is an indentation introducer: follow the rule adamc@350: (if noindent adamc@350: ;;(current-column) adamc@350: sym-indent adamc@350: (+ sym-indent indent-after))) adamc@350: ;; If we're just after a hanging open paren. adamc@350: ((and (eq (char-syntax (preceding-char)) ?\() adamc@350: (save-excursion (backward-char) (urweb-dangling-sym))) adamc@350: (backward-char) adamc@350: (urweb-indent-default)) adamc@350: (t adamc@350: ;; default-default adamc@350: (let* ((prec-after (urweb-op-prec sym-after 'back)) adamc@350: (prec (or (urweb-op-prec sym-before 'back) prec-after 100))) adamc@350: ;; go back until you hit a symbol that has a lower prec than the adamc@350: ;; "current one", or until you backed over a sym that has the same prec adamc@350: ;; but is at the beginning of a line. adamc@350: (while (and (not (urweb-bolp)) adamc@350: (while (urweb-move-if (urweb-backward-sexp (1- prec)))) adamc@350: (not (urweb-bolp))) adamc@350: (while (urweb-move-if (urweb-backward-sexp prec)))) adamc@350: (if noindent adamc@350: ;; the `noindent' case does back over an introductory symbol adamc@350: ;; such as `fun', ... adamc@350: (progn adamc@350: (urweb-move-if adamc@350: (urweb-backward-spaces) adamc@350: (member (urweb-backward-sym) urweb-starters-syms)) adamc@350: (current-column)) adamc@350: ;; Use `indent-after' for cases such as when , or ; should be adamc@350: ;; outdented so that their following terms are aligned. adamc@350: (+ (if (progn adamc@350: (if (equal sym-after ";") adamc@350: (urweb-move-if adamc@350: (urweb-backward-spaces) adamc@350: (member (urweb-backward-sym) urweb-starters-syms))) adamc@350: (and sym-after (not (looking-at sym-after)))) adamc@350: indent-after 0) adamc@350: (current-column)))))))) adamc@350: adamc@350: adamc@350: ;; maybe `|' should be set to word-syntax in our temp syntax table ? adamc@350: (defun urweb-current-indentation () adamc@350: (save-excursion adamc@350: (beginning-of-line) adamc@350: (skip-chars-forward " \t|") adamc@350: (current-column))) adamc@350: adamc@350: adamc@350: (defun urweb-find-matching-starter (syms &optional prec) adamc@350: (let (sym) adamc@350: (ignore-errors adamc@350: (while adamc@350: (progn (urweb-backward-sexp prec) adamc@350: (setq sym (save-excursion (urweb-forward-sym))) adamc@350: (not (or (member sym syms) (bobp))))) adamc@350: (if (member sym syms) sym)))) adamc@350: adamc@350: (defun urweb-skip-siblings () adamc@350: (while (and (not (bobp)) (urweb-backward-arg)) adamc@350: (urweb-find-matching-starter urweb-starters-syms))) adamc@350: adamc@350: (defun urweb-beginning-of-defun () adamc@350: (let ((sym (urweb-find-matching-starter urweb-starters-syms))) adamc@350: (if (member sym '("fun" "and" "functor" "signature" "structure" adamc@350: "datatype")) adamc@350: (save-excursion (urweb-forward-sym) (urweb-forward-spaces) adamc@350: (urweb-forward-sym)) adamc@350: ;; We're inside a "non function declaration": let's skip all other adamc@350: ;; declarations that we find at the same level and try again. adamc@350: (urweb-skip-siblings) adamc@350: ;; Obviously, let's not try again if we're at bobp. adamc@350: (unless (bobp) (urweb-beginning-of-defun))))) adamc@350: adamc@350: (defcustom urweb-max-name-components 3 adamc@350: "Maximum number of components to use for the current function name." adamc@350: :group 'urweb adamc@350: :type 'integer) adamc@350: adamc@350: (defun urweb-current-fun-name () adamc@350: (save-excursion adamc@350: (let ((count urweb-max-name-components) adamc@350: fullname name) adamc@350: (end-of-line) adamc@350: (while (and (> count 0) adamc@350: (setq name (urweb-beginning-of-defun))) adamc@350: (decf count) adamc@350: (setq fullname (if fullname (concat name "." fullname) name)) adamc@350: ;; Skip all other declarations that we find at the same level. adamc@350: (urweb-skip-siblings)) adamc@350: fullname))) adamc@350: adamc@350: (provide 'urweb-mode) adamc@350: adamc@350: ;;; urweb-mode.el ends here