Mercurial > urweb
changeset 350:3a1e36b14105
First sort-of-working run of urweb-mode
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 12 Oct 2008 10:04:17 -0400 |
| parents | beb72f8a7218 |
| children | d5148178a7be |
| files | src/elisp/urweb-compat.el src/elisp/urweb-defs.el src/elisp/urweb-mode-startup.el src/elisp/urweb-mode.el src/elisp/urweb-move.el src/elisp/urweb-util.el tests/crud1.ur |
| diffstat | 7 files changed, 1488 insertions(+), 39 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-compat.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,111 @@ +;;; urweb-compat.el --- Compatibility functions for Emacs variants for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;;; Code: + +(require 'cl) + +(unless (fboundp 'set-keymap-parents) + (defun set-keymap-parents (m parents) + (if (keymapp parents) (setq parents (list parents))) + (set-keymap-parent + m + (if (cdr parents) + (reduce (lambda (m1 m2) + (let ((m (copy-keymap m1))) + (set-keymap-parent m m2) m)) + parents + :from-end t) + (car parents))))) + +;; for XEmacs +(when (fboundp 'temp-directory) + (defvar temporary-file-directory (temp-directory))) + +(unless (fboundp 'make-temp-file) + ;; Copied from Emacs-21's subr.el + (defun make-temp-file (prefix &optional dir-flag) + "Create a temporary file. +The returned file name (created by appending some random characters at the end +of PREFIX, and expanding against `temporary-file-directory' if necessary, +is guaranteed to point to a newly created empty file. +You can then use `write-region' to write new data into the file. + +If DIR-FLAG is non-nil, create a new empty directory instead of a file." + (let (file) + (while (condition-case () + (progn + (setq file + (make-temp-name + (expand-file-name prefix temporary-file-directory))) + (if dir-flag + (make-directory file) + (write-region "" nil file nil 'silent)) + nil) + (file-already-exists t)) + ;; the file was somehow created by someone else between + ;; `make-temp-name' and `write-region', let's try again. + nil) + file))) + + + +(unless (fboundp 'regexp-opt) + (defun regexp-opt (strings &optional paren) + (let ((open (if paren "\\(" "")) (close (if paren "\\)" ""))) + (concat open (mapconcat 'regexp-quote strings "\\|") close)))) + + +;;;; +;;;; Custom +;;;; + +;; doesn't exist in Emacs < 20.1 +(unless (fboundp 'set-face-bold-p) + (defun set-face-bold-p (face v &optional f) + (when v (ignore-errors (make-face-bold face))))) +(unless (fboundp 'set-face-italic-p) + (defun set-face-italic-p (face v &optional f) + (when v (ignore-errors (make-face-italic face))))) + +;; doesn't exist in Emacs < 20.1 +(ignore-errors (require 'custom)) +(unless (fboundp 'defgroup) + (defmacro defgroup (&rest rest) ())) +(unless (fboundp 'defcustom) + (defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str))) +(unless (fboundp 'defface) + (defmacro defface (sym val str &rest rest) + `(defvar ,sym (make-face ',sym) ,str))) + +(defvar :group ':group) +(defvar :type ':type) +(defvar :copy ':copy) +(defvar :dense ':dense) +(defvar :inherit ':inherit) +(defvar :suppress ':suppress) + +(provide 'urweb-compat) + +;;; urweb-compat.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-defs.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,202 @@ +;;; urweb-defs.el --- Various definitions for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999,2000,2003 Stefan Monnier <monnier@cs.yale.edu> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'sml-util) + + +(defgroup urweb () + "Editing Ur/Web code." + :group 'languages) + +(defvar urweb-outline-regexp + ;; `st' and `si' are to match structure and signature. + " \\|s[ti]\\|[ \t]*\\(let[ \t]+\\)?\\(fun\\|and\\)\\>" + "Regexp matching a major heading. +This actually can't work without extending `outline-minor-mode' with the +notion of \"the end of an outline\".") + +;;; +;;; Internal defines +;;; + +(defmap urweb-mode-map + ;; smarter cursor movement + '(("\C-c\C-i" . urweb-mode-info)) + "The keymap used in `urweb-mode'." + ;; :inherit urweb-bindings + :group 'urweb) + +(defsyntax urweb-mode-syntax-table + `((?\* . ,(if urweb-builtin-nested-comments-flag ". 23n" ". 23")) + (?\( . "()1") + (?\) . ")(4") + ("._'" . "_") + (",;" . ".") + ;; `!' is not really a prefix-char, oh well! + ("~#!" . "'") + ("%&$+-/:<=>?@`^|" . ".")) + "The syntax table used in `urweb-mode'.") + + +(easy-menu-define urweb-mode-menu urweb-mode-map "Menu used in `urweb-mode'." + '("URWEB" + ["URWEB mode help (brief)" describe-mode t] + ["URWEB mode *info*" urweb-mode-info t] + )) + +;; Make's sure they appear in the menu bar when urweb-mode-map is active. +;; On the hook for XEmacs only -- see easy-menu-add in auc-menu.el. +;; (defun urweb-mode-menu-bar () +;; "Make sure menus appear in the menu bar as well as under mouse 3." +;; (and (eq major-mode 'urweb-mode) +;; (easy-menu-add urweb-mode-menu urweb-mode-map))) +;; (add-hook 'urweb-mode-hook 'urweb-mode-menu-bar) + +;; +;; regexps +;; + +(defun urweb-syms-re (&rest syms) + (concat "\\<" (regexp-opt (flatten syms) t) "\\>")) + +;; + +(defconst urweb-module-head-syms + '("signature" "structure" "functor")) + + +(defconst urweb-begin-syms + '("struct" "sig") + "Symbols matching the `end' symbol.") + +(defconst urweb-begin-syms-re + (urweb-syms-re urweb-begin-syms) + "Symbols matching the `end' symbol.") + +;; (defconst urweb-user-begin-symbols-re +;; (urweb-syms-re "let" "abstype" "local" "struct" "sig" "in" "with") +;; "Symbols matching (loosely) the `end' symbol.") + +(defconst urweb-sexp-head-symbols-re + (urweb-syms-re "struct" "sig" "with" + "if" "then" "else" "case" "of" "fn" "fun" "val" "and" + "datatype" "type" "open" "include" + urweb-module-head-syms + "con" "fold" "where" "extern" "constraint" "constraints" + "table" "sequence" "class") + "Symbols starting an sexp.") + +;; (defconst urweb-not-arg-start-re +;; (urweb-syms-re "in" "of" "end" "andalso") +;; "Symbols that can't be found at the head of an arg.") + +;; (defconst urweb-not-arg-re +;; (urweb-syms-re "in" "of" "end" "andalso") +;; "Symbols that should not be confused with an arg.") + +(defconst urweb-=-starter-syms + (list* "|" "val" "fun" "and" "datatype" "con" "type" "class" + urweb-module-head-syms) + "Symbols that can be followed by a `='.") +(defconst urweb-=-starter-re + (concat "\\S.|\\S.\\|" (urweb-syms-re (cdr urweb-=-starter-syms))) + "Symbols that can be followed by a `='.") + +(defconst urweb-indent-rule + (urweb-preproc-alist + `((,urweb-module-head-syms "d=" 0) + ("if" "else" 0) + (,urweb-=-starter-syms nil) + (("case" "datatype" "if" "then" "else" + "open" "sig" "struct" "type" "val" + "con" "constraint" "table" "sequence" "class"))))) + +(defconst urweb-starters-indent-after + (urweb-syms-re "struct" "sig") + "Indent after these.") + +(defconst urweb-delegate + (urweb-preproc-alist + `((("of" "else" "then" "with" "d=") . (not (urweb-bolp))) + ("in" . t))) + "Words which might delegate indentation to their parent.") + +(defcustom urweb-symbol-indent + '(("fn" . -3) + ("of" . 1) + ("|" . -2) + ("," . -2) + (";" . -2) + ;;("in" . 1) + ("d=" . 2)) + "Special indentation alist for some symbols. +An entry like (\"in\" . 1) indicates that a line starting with the +symbol `in' should be indented one char further to the right. +This is only used in a few specific cases, so it does not work +for all symbols and in all lines starting with the given symbol." + :group 'urweb + :type '(repeat (cons string integer))) + +(defconst urweb-open-paren + (urweb-preproc-alist + `((,(list* urweb-begin-syms) ,urweb-begin-syms-re "\\<end\\>"))) + "Symbols that should behave somewhat like opening parens.") + +(defconst urweb-close-paren + `(("end" ,urweb-begin-syms-re) + ("then" "\\<if\\>") + ("else" "\\<if\\>" (urweb-bolp)) + ("of" "\\<case\\>") + ("d=" nil)) + "Symbols that should behave somewhat like close parens.") + +(defconst urweb-agglomerate-re "\\<else[ \t]+if\\>" + "Regexp of compound symbols (pairs of symbols to be considered as one).") + +(defconst urweb-non-nested-of-starter-re + (urweb-syms-re "datatype") + "Symbols that can introduce an `of' that shouldn't behave like a paren.") + +(defconst urweb-starters-syms + (append urweb-module-head-syms + '("datatype" "fun" + "open" "type" "val" "and" + "con" "constraint" "table" "sequence" "class")) + "The starters of new expressions.") + +(defconst urweb-exptrail-syms + '("if" "then" "else" "case" "of" "fn" "with" "fold")) + +(defconst urweb-pipeheads + '("|" "of" "fun" "fn" "and" "datatype") + "A `|' corresponds to one of these.") + + +(provide 'urweb-defs) + +;;; urweb-defs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-mode-startup.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,20 @@ + +;;; Generated autoloads from urweb-mode.el + (add-to-list 'load-path (file-name-directory load-file-name)) + +(add-to-list (quote auto-mode-alist) (quote ("\\.ur\\(s\\)?\\'" . urweb-mode))) + +(autoload (quote urweb-mode) "urweb-mode" "\ +\\<urweb-mode-map>Major mode for editing Ur/Web code. +This mode runs `urweb-mode-hook' just before exiting. +\\{urweb-mode-map} + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("urweb-compat.el" "urweb-defs.el" +;;;;;; "urweb-util.el") (18072 34664 948142)) + +;;;*** +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-mode.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,665 @@ +;;; urweb-mode.el --- Major mode for editing (Standard) ML + +;; Based on sml-mode: +;; Copyright (C) 1999,2000,2004 Stefan Monnier +;; Copyright (C) 1994-1997 Matthew J. Morley +;; Copyright (C) 1989 Lars Bo Nielsen +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> + +;; Author: Lars Bo Nielsen +;; Olin Shivers +;; Fritz Knabe (?) +;; Steven Gilmore (?) +;; Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>) +;; Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>) +;; (Stefan Monnier) monnier@cs.yale.edu +;; Adam Chlipala + +;; This file is not part of GNU Emacs, but it is distributed under the +;; same conditions. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;;; HISTORY + +;; Still under construction: History obscure, needs a biographer as +;; well as a M-x doctor. Change Log on request. + +;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's urweb.el. + +;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and +;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus, +;; and numerous bugs and bug-fixes. + +;;; DESCRIPTION + +;; See accompanying info file: urweb-mode.info + +;;; FOR YOUR .EMACS FILE + +;; If urweb-mode.el lives in some non-standard directory, you must tell +;; emacs where to get it. This may or may not be necessary: + +;; (add-to-list 'load-path "~jones/lib/emacs/") + +;; Then to access the commands autoload urweb-mode with that command: + +;; (load "urweb-mode-startup") + +;; urweb-mode-hook is run whenever a new urweb-mode buffer is created. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'urweb-util) +(require 'urweb-move) +(require 'urweb-defs) +(condition-case nil (require 'skeleton) (error nil)) + +;;; VARIABLES CONTROLLING INDENTATION + +(defcustom urweb-indent-level 4 + "*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')." + :group 'urweb + :type '(integer)) + +(defcustom urweb-indent-args urweb-indent-level + "*Indentation of args placed on a separate line." + :group 'urweb + :type '(integer)) + +(defcustom urweb-electric-semi-mode nil + "*If non-nil, `\;' will self insert, reindent the line, and do a newline. +If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)." + :group 'urweb + :type 'boolean) + +(defcustom urweb-rightalign-and t + "If non-nil, right-align `and' with its leader. +If nil: If t: + datatype a = A datatype a = A + and b = B and b = B" + :group 'urweb + :type 'boolean) + +;;; OTHER GENERIC MODE VARIABLES + +(defvar urweb-mode-info "urweb-mode" + "*Where to find Info file for `urweb-mode'. +The default assumes the info file \"urweb-mode.info\" is on Emacs' info +directory path. If it is not, either put the file on the standard path +or set the variable `urweb-mode-info' to the exact location of this file + + (setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\") + +in your .emacs file. You can always set it interactively with the +set-variable command.") + +(defvar urweb-mode-hook nil + "*Run upon entering `urweb-mode'. +This is a good place to put your preferred key bindings.") + +;;; CODE FOR Ur/Web-MODE + +(defun urweb-mode-info () + "Command to access the TeXinfo documentation for `urweb-mode'. +See doc for the variable `urweb-mode-info'." + (interactive) + (require 'info) + (condition-case nil + (info urweb-mode-info) + (error (progn + (describe-variable 'urweb-mode-info) + (message "Can't find it... set this variable first!"))))) + + +;; font-lock setup + +(defconst urweb-keywords-regexp + (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints" + "datatype" "else" "end" "extern" "fn" "fold" + "fun" "functor" "if" "include" + "of" "open" + "rec" "sequence" "sig" "signature" + "struct" "structure" "table" "then" "type" "val" "where" + "with" + + "Name" "Type" "Unit") + "A regexp that matches any non-SQL keywords of Ur/Web.") + +(defconst urweb-sql-keywords-regexp + (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" + "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT" + "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX" + "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE") + "A regexp that matches SQL keywords.") + +;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The font lock regular expressions. + +(defconst urweb-font-lock-keywords + `(;;(urweb-font-comments-and-strings) + (,(concat "\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]") + (1 font-lock-keyword-face) + (6 font-lock-function-name-face)) + (,(concat "\\<\\(\\(data\\)?type\\|con\\)\\s-+\\(\\sw+\\)") + (1 font-lock-keyword-face) + (7 font-lock-type-def-face)) + ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + (1 font-lock-keyword-face) + (3 font-lock-variable-name-face)) + ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" + (1 font-lock-keyword-face) + (2 font-lock-module-def-face)) + ("\\<\\(signature\\)\\s-+\\(\\sw+\\)" + (1 font-lock-keyword-face) + (2 font-lock-interface-def-face)) + + (,urweb-keywords-regexp . font-lock-keyword-face) + (,urweb-sql-keywords-regexp . font-lock-sql-face)) + "Regexps matching standard Ur/Web keywords.") + +(defface font-lock-type-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight type definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-type-def-face 'font-lock-type-def-face + "Face name to use for type definitions.") + +(defface font-lock-module-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight module definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-module-def-face 'font-lock-module-def-face + "Face name to use for module definitions.") + +(defface font-lock-interface-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight interface definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-interface-def-face 'font-lock-interface-def-face + "Face name to use for interface definitions.") + +(defface font-lock-sql-face + '((t (:bold t))) + "Font Lock mode face used to highlight SQL keywords." + :group 'font-lock-highlighting-faces) +(defvar font-lock-sql-face 'font-lock-sql-face + "Face name to use for SQL keywords.") + +;; +;; Code to handle nested comments and unusual string escape sequences +;; + +(defsyntax urweb-syntax-prop-table + '((?\\ . ".") (?* . ".")) + "Syntax table for text-properties") + +;; For Emacsen that have no built-in support for nested comments +(defun urweb-get-depth-st () + (save-excursion + (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil)) + (_ (backward-char)) + (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp)) + (pt (point))) + (when disp + (let* ((depth + (save-match-data + (if (re-search-backward "\\*)\\|(\\*" nil t) + (+ (or (get-char-property (point) 'comment-depth) 0) + (case (char-after) (?\( 1) (?* 0)) + disp) + 0))) + (depth (if (> depth 0) depth))) + (put-text-property pt (1+ pt) 'comment-depth depth) + (when depth urweb-syntax-prop-table)))))) + +(defconst urweb-font-lock-syntactic-keywords + `(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table)) + ,@(unless urweb-builtin-nested-comments-flag + '(("(?\\(\\*\\))?" (1 (urweb-get-depth-st))))))) + +(defconst urweb-font-lock-defaults + '(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil + (font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords))) + +;;;; +;;;; Imenu support +;;;; + +(defvar urweb-imenu-regexp + (concat "^[ \t]*\\(let[ \t]+\\)?" + (regexp-opt (append urweb-module-head-syms + '("and" "fun" "datatype" "type")) t) + "\\>")) + +(defun urweb-imenu-create-index () + (let (alist) + (goto-char (point-max)) + (while (re-search-backward urweb-imenu-regexp nil t) + (save-excursion + (let ((kind (match-string 2)) + (column (progn (goto-char (match-beginning 2)) (current-column))) + (location + (progn (goto-char (match-end 0)) + (urweb-forward-spaces) + (when (looking-at urweb-tyvarseq-re) + (goto-char (match-end 0))) + (point))) + (name (urweb-forward-sym))) + ;; Eliminate trivial renamings. + (when (or (not (member kind '("structure" "signature"))) + (progn (search-forward "=") + (urweb-forward-spaces) + (looking-at "sig\\|struct"))) + (push (cons (concat (make-string (/ column 2) ?\ ) name) location) + alist))))) + alist)) + +;;; MORE CODE FOR URWEB-MODE + +;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name)) +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.s\\(ml\\|ig\\)\\'" . urweb-mode)) + +;;;###autoload +(define-derived-mode urweb-mode fundamental-mode "Ur/Web" + "\\<urweb-mode-map>Major mode for editing Ur/Web code. +This mode runs `urweb-mode-hook' just before exiting. +\\{urweb-mode-map}" + (set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults) + (set (make-local-variable 'outline-regexp) urweb-outline-regexp) + (set (make-local-variable 'imenu-create-index-function) + 'urweb-imenu-create-index) + (set (make-local-variable 'add-log-current-defun-function) + 'urweb-current-fun-name) + ;; Treat paragraph-separators in comments as paragraph-separators. + (set (make-local-variable 'paragraph-separate) + (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)")) + (set (make-local-variable 'require-final-newline) t) + ;; forward-sexp-function is an experimental variable in my hacked Emacs. + (set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp) + ;; For XEmacs + (easy-menu-add urweb-mode-menu) + ;; Compatibility. FIXME: we should use `-' in Emacs-CVS. + (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil)) + (urweb-mode-variables)) + +(defun urweb-mode-variables () + (set-syntax-table urweb-mode-syntax-table) + (setq local-abbrev-table urweb-mode-abbrev-table) + ;; A paragraph is separated by blank lines or ^L only. + + (set (make-local-variable 'indent-line-function) 'urweb-indent-line) + (set (make-local-variable 'comment-start) "(* ") + (set (make-local-variable 'comment-end) " *)") + (set (make-local-variable 'comment-nested) t) + ;;(set (make-local-variable 'block-comment-start) "* ") + ;;(set (make-local-variable 'block-comment-end) "") + ;; (set (make-local-variable 'comment-column) 40) + (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")) + +(defun urweb-funname-of-and () + "Name of the function this `and' defines, or nil if not a function. +Point has to be right after the `and' symbol and is not preserved." + (urweb-forward-spaces) + (if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0))) + (let ((sym (urweb-forward-sym))) + (urweb-forward-spaces) + (unless (or (member sym '(nil "d=")) + (member (urweb-forward-sym) '("d="))) + sym))) + +;;; INDENTATION !!! + +(defun urweb-mark-function () + "Synonym for `mark-paragraph' -- sorry. +If anyone has a good algorithm for this..." + (interactive) + (mark-paragraph)) + +(defun urweb-indent-line () + "Indent current line of Ur/Web code." + (interactive) + (let ((savep (> (current-column) (current-indentation))) + (indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0))) + (if savep + (save-excursion (indent-line-to indent)) + (indent-line-to indent)))) + +(defun urweb-back-to-outer-indent () + "Unindents to the next outer level of indentation." + (interactive) + (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (let ((start-column (current-column)) + (indent (current-column))) + (if (> start-column 0) + (progn + (save-excursion + (while (>= indent start-column) + (if (re-search-backward "^[^\n]" nil t) + (setq indent (current-indentation)) + (setq indent 0)))) + (backward-delete-char-untabify (- start-column indent))))))) + +(defun urweb-find-comment-indent () + (save-excursion + (let ((depth 1)) + (while (> depth 0) + (if (re-search-backward "(\\*\\|\\*)" nil t) + (cond + ;; FIXME: That's just a stop-gap. + ((eq (get-text-property (point) 'face) 'font-lock-string-face)) + ((looking-at "*)") (incf depth)) + ((looking-at comment-start-skip) (decf depth))) + (setq depth -1))) + (if (= depth 0) + (1+ (current-column)) + nil)))) + +(defun urweb-calculate-indentation () + (save-excursion + (beginning-of-line) (skip-chars-forward "\t ") + (urweb-with-ist + ;; Indentation for comments alone on a line, matches the + ;; proper indentation of the next line. + (when (looking-at "(\\*") (urweb-forward-spaces)) + (let (data + (sym (save-excursion (urweb-forward-sym)))) + (or + ;; Allow the user to override the indentation. + (when (looking-at (concat ".*" (regexp-quote comment-start) + "[ \t]*fixindent[ \t]*" + (regexp-quote comment-end))) + (current-indentation)) + + ;; Continued comment. + (and (looking-at "\\*") (urweb-find-comment-indent)) + + ;; Continued string ? (Added 890113 lbn) + (and (looking-at "\\\\") + (save-excursion + (if (save-excursion (previous-line 1) + (beginning-of-line) + (looking-at "[\t ]*\\\\")) + (progn (previous-line 1) (current-indentation)) + (if (re-search-backward "[^\\\\]\"" nil t) + (1+ (current-column)) + 0)))) + + ;; Closing parens. Could be handled below with `urweb-indent-relative'? + (and (looking-at "\\s)") + (save-excursion + (skip-syntax-forward ")") + (backward-sexp 1) + (if (urweb-dangling-sym) + (urweb-indent-default 'noindent) + (current-column)))) + + (and (setq data (assoc sym urweb-close-paren)) + (urweb-indent-relative sym data)) + + (and (member sym urweb-starters-syms) + (urweb-indent-starter sym)) + + (and (string= sym "|") (urweb-indent-pipe)) + + (urweb-indent-arg) + (urweb-indent-default)))))) + +(defsubst urweb-bolp () + (save-excursion (skip-chars-backward " \t|") (bolp))) + +(defun urweb-indent-starter (orig-sym) + "Return the indentation to use for a symbol in `urweb-starters-syms'. +Point should be just before the symbol ORIG-SYM and is not preserved." + (let ((sym (unless (save-excursion (urweb-backward-arg)) + (urweb-backward-spaces) + (urweb-backward-sym)))) + (if (member sym '(";" "d=")) (setq sym nil)) + (if sym (urweb-get-sym-indent sym) + ;; FIXME: this can take a *long* time !! + (setq sym (urweb-find-matching-starter urweb-starters-syms)) + ;; Don't align with `and' because it might be specially indented. + (if (and (or (equal orig-sym "and") (not (equal sym "and"))) + (urweb-bolp)) + (+ (current-column) + (if (and urweb-rightalign-and (equal orig-sym "and")) + (- (length sym) 3) 0)) + (urweb-indent-starter orig-sym))))) + +(defun urweb-indent-relative (sym data) + (save-excursion + (urweb-forward-sym) (urweb-backward-sexp nil) + (unless (second data) (urweb-backward-spaces) (urweb-backward-sym)) + (+ (or (cdr (assoc sym urweb-symbol-indent)) 0) + (urweb-delegated-indent)))) + +(defun urweb-indent-pipe () + (let ((sym (urweb-find-matching-starter urweb-pipeheads + (urweb-op-prec "|" 'back)))) + (when sym + (if (string= sym "|") + (if (urweb-bolp) (current-column) (urweb-indent-pipe)) + (let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2))) + (when (or (member sym '("datatype")) + (and (equal sym "and") + (save-excursion + (forward-word 1) + (not (urweb-funname-of-and))))) + (re-search-forward "=")) + (urweb-forward-sym) + (urweb-forward-spaces) + (+ pipe-indent (current-column))))))) + +(defun urweb-find-forward (re) + (urweb-forward-spaces) + (while (and (not (looking-at re)) + (progn + (or (ignore-errors (forward-sexp 1) t) (forward-char 1)) + (urweb-forward-spaces) + (not (looking-at re)))))) + +(defun urweb-indent-arg () + (and (save-excursion (ignore-errors (urweb-forward-arg))) + ;;(not (looking-at urweb-not-arg-re)) + ;; looks like a function or an argument + (urweb-move-if (urweb-backward-arg)) + ;; an argument + (if (save-excursion (not (urweb-backward-arg))) + ;; a first argument + (+ (current-column) urweb-indent-args) + ;; not a first arg + (while (and (/= (current-column) (current-indentation)) + (urweb-move-if (urweb-backward-arg)))) + (unless (save-excursion (urweb-backward-arg)) + ;; all earlier args are on the same line + (urweb-forward-arg) (urweb-forward-spaces)) + (current-column)))) + +(defun urweb-get-indent (data sym) + (let (d) + (cond + ((not (listp data)) data) + ((setq d (member sym data)) (cadr d)) + ((and (consp data) (not (stringp (car data)))) (car data)) + (t urweb-indent-level)))) + +(defun urweb-dangling-sym () + "Non-nil if the symbol after point is dangling. +The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that +it is not on its own line but is the last element on that line." + (save-excursion + (and (not (urweb-bolp)) + (< (urweb-point-after (end-of-line)) + (urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "(")) + (urweb-forward-spaces)))))) + +(defun urweb-delegated-indent () + (if (urweb-dangling-sym) + (urweb-indent-default 'noindent) + (urweb-move-if (backward-word 1) + (looking-at urweb-agglomerate-re)) + (current-column))) + +(defun urweb-get-sym-indent (sym &optional style) + "Find the indentation for the SYM we're `looking-at'. +If indentation is delegated, point will move to the start of the parent. +Optional argument STYLE is currently ignored." + (assert (equal sym (save-excursion (urweb-forward-sym)))) + (save-excursion + (let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren))) + (head-sym sym)) + (when (and delegate (not (eval (third delegate)))) + ;;(urweb-find-match-backward sym delegate) + (urweb-forward-sym) (urweb-backward-sexp nil) + (setq head-sym + (if (second delegate) + (save-excursion (urweb-forward-sym)) + (urweb-backward-spaces) (urweb-backward-sym)))) + + (let ((idata (assoc head-sym urweb-indent-rule))) + (when idata + ;;(if (or style (not delegate)) + ;; normal indentation + (let ((indent (urweb-get-indent (cdr idata) sym))) + (when indent (+ (urweb-delegated-indent) indent))) + ;; delgate indentation to the parent + ;;(urweb-forward-sym) (urweb-backward-sexp nil) + ;;(let* ((parent-sym (save-excursion (urweb-forward-sym))) + ;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters)))) + ;; check the special rules + ;;(+ (urweb-delegated-indent) + ;; (or (urweb-get-indent (cdr indent-data) 1 'strict) + ;; (urweb-get-indent (cdr parent-indent) 1 'strict) + ;; (urweb-get-indent (cdr indent-data) 0) + ;; (urweb-get-indent (cdr parent-indent) 0)))))))) + ))))) + +(defun urweb-indent-default (&optional noindent) + (let* ((sym-after (save-excursion (urweb-forward-sym))) + (_ (urweb-backward-spaces)) + (sym-before (urweb-backward-sym)) + (sym-indent (and sym-before (urweb-get-sym-indent sym-before))) + (indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0))) + (when (equal sym-before "end") + ;; I don't understand what's really happening here, but when + ;; it's `end' clearly, we need to do something special. + (forward-word 1) + (setq sym-before nil sym-indent nil)) + (cond + (sym-indent + ;; the previous sym is an indentation introducer: follow the rule + (if noindent + ;;(current-column) + sym-indent + (+ sym-indent indent-after))) + ;; If we're just after a hanging open paren. + ((and (eq (char-syntax (preceding-char)) ?\() + (save-excursion (backward-char) (urweb-dangling-sym))) + (backward-char) + (urweb-indent-default)) + (t + ;; default-default + (let* ((prec-after (urweb-op-prec sym-after 'back)) + (prec (or (urweb-op-prec sym-before 'back) prec-after 100))) + ;; go back until you hit a symbol that has a lower prec than the + ;; "current one", or until you backed over a sym that has the same prec + ;; but is at the beginning of a line. + (while (and (not (urweb-bolp)) + (while (urweb-move-if (urweb-backward-sexp (1- prec)))) + (not (urweb-bolp))) + (while (urweb-move-if (urweb-backward-sexp prec)))) + (if noindent + ;; the `noindent' case does back over an introductory symbol + ;; such as `fun', ... + (progn + (urweb-move-if + (urweb-backward-spaces) + (member (urweb-backward-sym) urweb-starters-syms)) + (current-column)) + ;; Use `indent-after' for cases such as when , or ; should be + ;; outdented so that their following terms are aligned. + (+ (if (progn + (if (equal sym-after ";") + (urweb-move-if + (urweb-backward-spaces) + (member (urweb-backward-sym) urweb-starters-syms))) + (and sym-after (not (looking-at sym-after)))) + indent-after 0) + (current-column)))))))) + + +;; maybe `|' should be set to word-syntax in our temp syntax table ? +(defun urweb-current-indentation () + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t|") + (current-column))) + + +(defun urweb-find-matching-starter (syms &optional prec) + (let (sym) + (ignore-errors + (while + (progn (urweb-backward-sexp prec) + (setq sym (save-excursion (urweb-forward-sym))) + (not (or (member sym syms) (bobp))))) + (if (member sym syms) sym)))) + +(defun urweb-skip-siblings () + (while (and (not (bobp)) (urweb-backward-arg)) + (urweb-find-matching-starter urweb-starters-syms))) + +(defun urweb-beginning-of-defun () + (let ((sym (urweb-find-matching-starter urweb-starters-syms))) + (if (member sym '("fun" "and" "functor" "signature" "structure" + "datatype")) + (save-excursion (urweb-forward-sym) (urweb-forward-spaces) + (urweb-forward-sym)) + ;; We're inside a "non function declaration": let's skip all other + ;; declarations that we find at the same level and try again. + (urweb-skip-siblings) + ;; Obviously, let's not try again if we're at bobp. + (unless (bobp) (urweb-beginning-of-defun))))) + +(defcustom urweb-max-name-components 3 + "Maximum number of components to use for the current function name." + :group 'urweb + :type 'integer) + +(defun urweb-current-fun-name () + (save-excursion + (let ((count urweb-max-name-components) + fullname name) + (end-of-line) + (while (and (> count 0) + (setq name (urweb-beginning-of-defun))) + (decf count) + (setq fullname (if fullname (concat name "." fullname) name)) + ;; Skip all other declarations that we find at the same level. + (urweb-skip-siblings)) + fullname))) + +(provide 'urweb-mode) + +;;; urweb-mode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-move.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,334 @@ +;;; urweb-move.el --- Buffer navigation functions for urweb-mode + +;; Based on urweb-mode: +;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'urweb-util) +(require 'urweb-defs) + +(defsyntax urweb-internal-syntax-table + '((?_ . "w") + (?' . "w") + (?. . "w")) + "Syntax table used for internal urweb-mode operation." + :copy urweb-mode-syntax-table) + +;;; +;;; various macros +;;; + +(defmacro urweb-with-ist (&rest r) + (let ((ost-sym (make-symbol "oldtable"))) + `(let ((,ost-sym (syntax-table)) + (case-fold-search nil) + (parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (unwind-protect + (progn (set-syntax-table urweb-internal-syntax-table) . ,r) + (set-syntax-table ,ost-sym))))) +(def-edebug-spec urweb-with-ist t) + +(defmacro urweb-move-if (&rest body) + (let ((pt-sym (make-symbol "point")) + (res-sym (make-symbol "result"))) + `(let ((,pt-sym (point)) + (,res-sym ,(cons 'progn body))) + (unless ,res-sym (goto-char ,pt-sym)) + ,res-sym))) +(def-edebug-spec urweb-move-if t) + +(defmacro urweb-point-after (&rest body) + `(save-excursion + ,@body + (point))) +(def-edebug-spec urweb-point-after t) + +;; + +(defvar urweb-op-prec + (urweb-preproc-alist + '((("UNION" "INTERSECT" "EXCEPT") . 0) + (("AND" "OR") . 1) + ((">" ">=" "<>" "<" "<=" "=") . 4) + (("+" "-" "^") . 6) + (("/" "*" "%") . 7) + (("++" "--") 8) + (("NOT") 9) + (("~" "$") 10))) + "Alist of Ur/Web infix operators and their precedence.") + +(defconst urweb-syntax-prec + (urweb-preproc-alist + `(((";" ",") . 20) + (("=>" "d=" "=of") . (65 . 40)) + ("|" . (47 . 30)) + (("case" "of" "fn") . 45) + (("if" "then" "else" ) . 50) + (("<-") . 55) + ("||" . 70) + ("&&" . 80) + ((":" "::" ":::" ":>") . 90) + ("->" . 95) + ("with" . 100) + (,(cons "end" urweb-begin-syms) . 10000))) + "Alist of pseudo-precedence of syntactic elements.") + +(defun urweb-op-prec (op dir) + "Return the precedence of OP or nil if it's not an infix. +DIR should be set to BACK if you want to precedence w.r.t the left side + and to FORW for the precedence w.r.t the right side. +This assumes that we are `looking-at' the OP." + (when op + (let ((sprec (cdr (assoc op urweb-syntax-prec)))) + (cond + ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec))) + (sprec sprec) + (t + (let ((prec (cdr (assoc op urweb-op-prec)))) + (when prec (+ prec 100)))))))) + +;; + +(defun urweb-forward-spaces () (forward-comment 100000)) +(defun urweb-backward-spaces () (forward-comment -100000)) + + +;; +;; moving forward around matching symbols +;; + +(defun urweb-looking-back-at (re) + (save-excursion + (when (= 0 (skip-syntax-backward "w_")) (backward-char)) + (looking-at re))) + +(defun urweb-find-match-forward (this match) + "Only works for word matches." + (let ((level 1) + (forward-sexp-function nil) + (either (concat this "\\|" match))) + (while (> level 0) + (forward-sexp 1) + (while (not (or (eobp) (urweb-looking-back-at either))) + (condition-case () (forward-sexp 1) (error (forward-char 1)))) + (setq level + (cond + ((and (eobp) (> level 1)) (error "Unbalanced")) + ((urweb-looking-back-at this) (1+ level)) + ((urweb-looking-back-at match) (1- level)) + (t (error "Unbalanced"))))) + t)) + +(defun urweb-find-match-backward (this match) + (let ((level 1) + (forward-sexp-function nil) + (either (concat this "\\|" match))) + (while (> level 0) + (backward-sexp 1) + (while (not (or (bobp) (looking-at either))) + (condition-case () (backward-sexp 1) (error (backward-char 1)))) + (setq level + (cond + ((and (bobp) (> level 1)) (error "Unbalanced")) + ((looking-at this) (1+ level)) + ((looking-at match) (1- level)) + (t (error "Unbalanced"))))) + t)) + +;;; +;;; read a symbol, including the special "op <sym>" case +;;; + +(defmacro urweb-move-read (&rest body) + (let ((pt-sym (make-symbol "point"))) + `(let ((,pt-sym (point))) + ,@body + (when (/= (point) ,pt-sym) + (buffer-substring-no-properties (point) ,pt-sym))))) +(def-edebug-spec urweb-move-read t) + +(defun urweb-poly-equal-p () + (< (urweb-point-after (re-search-backward urweb-=-starter-re nil 'move)) + (urweb-point-after (re-search-backward "=" nil 'move)))) + +(defun urweb-nested-of-p () + (< (urweb-point-after + (re-search-backward urweb-non-nested-of-starter-re nil 'move)) + (urweb-point-after (re-search-backward "\\<case\\>" nil 'move)))) + +(defun urweb-forward-sym-1 () + (or (/= 0 (skip-syntax-forward "'w_")) + (/= 0 (skip-syntax-forward ".'")))) +(defun urweb-forward-sym () + (let ((sym (urweb-move-read (urweb-forward-sym-1)))) + (cond + ((equal "op" sym) + (urweb-forward-spaces) + (concat "op " (or (urweb-move-read (urweb-forward-sym-1)) ""))) + ((equal sym "=") + (save-excursion + (urweb-backward-sym-1) + (if (urweb-poly-equal-p) "=" "d="))) + ((equal sym "of") + (save-excursion + (urweb-backward-sym-1) + (if (urweb-nested-of-p) "of" "=of"))) + ;; ((equal sym "datatype") + ;; (save-excursion + ;; (urweb-backward-sym-1) + ;; (urweb-backward-spaces) + ;; (if (eq (preceding-char) ?=) "=datatype" sym))) + (t sym)))) + +(defun urweb-backward-sym-1 () + (or (/= 0 (skip-syntax-backward ".'")) + (/= 0 (skip-syntax-backward "'w_")))) +(defun urweb-backward-sym () + (let ((sym (urweb-move-read (urweb-backward-sym-1)))) + (when sym + ;; FIXME: what should we do if `sym' = "op" ? + (let ((point (point))) + (urweb-backward-spaces) + (if (equal "op" (urweb-move-read (urweb-backward-sym-1))) + (concat "op " sym) + (goto-char point) + (cond + ((string= sym "=") (if (urweb-poly-equal-p) "=" "d=")) + ((string= sym "of") (if (urweb-nested-of-p) "of" "=of")) + ;; ((string= sym "datatype") + ;; (save-excursion (urweb-backward-spaces) + ;; (if (eq (preceding-char) ?=) "=datatype" sym))) + (t sym))))))) + + +(defun urweb-backward-sexp (prec) + "Move one sexp backward if possible, or one char else. +Returns t if the move indeed moved through one sexp and nil if not. +PREC is the precedence currently looked for." + (let ((parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (urweb-backward-spaces) + (let* ((op (urweb-backward-sym)) + (op-prec (urweb-op-prec op 'back)) + match) + (cond + ((not op) + (let ((point (point))) + (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1))) + (if (/= point (point)) t (ignore-errors (backward-char 1)) nil))) + ;; stop as soon as precedence is smaller than `prec' + ((and prec op-prec (>= prec op-prec)) nil) + ;; special rules for nested constructs like if..then..else + ((and (or (not prec) (and prec op-prec)) + (setq match (second (assoc op urweb-close-paren)))) + (urweb-find-match-backward (concat "\\<" op "\\>") match)) + ;; don't back over open-parens + ((assoc op urweb-open-paren) nil) + ;; infix ops precedence + ((and prec op-prec) (< prec op-prec)) + ;; [ prec = nil ] a new operator, let's skip the sexps until the next + (op-prec (while (urweb-move-if (urweb-backward-sexp op-prec))) t) + ;; special symbols indicating we're getting out of a nesting level + ((string-match urweb-sexp-head-symbols-re op) nil) + ;; if the op was not alphanum, then we still have to do the backward-sexp + ;; this reproduces the usual backward-sexp, but it might be bogus + ;; in this case since !@$% is a perfectly fine symbol + (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) + +(defun urweb-forward-sexp (prec) + "Moves one sexp forward if possible, or one char else. +Returns T if the move indeed moved through one sexp and NIL if not." + (let ((parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (urweb-forward-spaces) + (let* ((op (urweb-forward-sym)) + (op-prec (urweb-op-prec op 'forw)) + match) + (cond + ((not op) + (let ((point (point))) + (ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1))) + (if (/= point (point)) t (forward-char 1) nil))) + ;; stop as soon as precedence is smaller than `prec' + ((and prec op-prec (>= prec op-prec)) nil) + ;; special rules for nested constructs like if..then..else + ((and (or (not prec) (and prec op-prec)) + (setq match (cdr (assoc op urweb-open-paren)))) + (urweb-find-match-forward (first match) (second match))) + ;; don't forw over close-parens + ((assoc op urweb-close-paren) nil) + ;; infix ops precedence + ((and prec op-prec) (< prec op-prec)) + ;; [ prec = nil ] a new operator, let's skip the sexps until the next + (op-prec (while (urweb-move-if (urweb-forward-sexp op-prec))) t) + ;; special symbols indicating we're getting out of a nesting level + ((string-match urweb-sexp-head-symbols-re op) nil) + ;; if the op was not alphanum, then we still have to do the backward-sexp + ;; this reproduces the usual backward-sexp, but it might be bogus + ;; in this case since !@$% is a perfectly fine symbol + (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) + +(defun urweb-in-word-p () + (and (eq ?w (char-syntax (or (char-before) ? ))) + (eq ?w (char-syntax (or (char-after) ? ))))) + +(defun urweb-user-backward-sexp (&optional count) + "Like `backward-sexp' but tailored to the Ur/Web syntax." + (interactive "p") + (unless count (setq count 1)) + (urweb-with-ist + (let ((point (point))) + (if (< count 0) (urweb-user-forward-sexp (- count)) + (when (urweb-in-word-p) (forward-word 1)) + (dotimes (i count) + (unless (urweb-backward-sexp nil) + (goto-char point) + (error "Containing expression ends prematurely"))))))) + +(defun urweb-user-forward-sexp (&optional count) + "Like `forward-sexp' but tailored to the Ur/Web syntax." + (interactive "p") + (unless count (setq count 1)) + (urweb-with-ist + (let ((point (point))) + (if (< count 0) (urweb-user-backward-sexp (- count)) + (when (urweb-in-word-p) (backward-word 1)) + (dotimes (i count) + (unless (urweb-forward-sexp nil) + (goto-char point) + (error "Containing expression ends prematurely"))))))) + +;;(defun urweb-forward-thing () +;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1))) + +(defun urweb-backward-arg () (urweb-backward-sexp 1000)) +(defun urweb-forward-arg () (urweb-forward-sexp 1000)) + + +(provide 'urweb-move) + +;;; urweb-move.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/elisp/urweb-util.el Sun Oct 12 10:04:17 2008 -0400 @@ -0,0 +1,123 @@ +;;; urweb-util.el --- Utility functions for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999-2000 Stefan Monnier <monnier@cs.yale.edu> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; Commentary: + +;;; Code: + +(require 'cl) ;for `reduce' +(require 'urweb-compat) + +;; + +(defun flatten (ls &optional acc) + (if (null ls) acc + (let ((rest (flatten (cdr ls) acc)) + (head (car ls))) + (if (listp head) + (flatten head rest) + (cons head rest))))) + +(defun urweb-preproc-alist (al) + "Expand an alist AL where keys can be lists of keys into a normal one." + (reduce (lambda (x al) + (let ((k (car x)) + (v (cdr x))) + (if (consp k) + (append (mapcar (lambda (y) (cons y v)) k) al) + (cons x al)))) + al + :initial-value nil + :from-end t)) + +;;; +;;; defmap +;;; + +(defun custom-create-map (m bs args) + (let (inherit dense suppress) + (while args + (let ((key (first args)) + (val (second args))) + (cond + ((eq key :dense) (setq dense val)) + ((eq key :inherit) (setq inherit val)) + ((eq key :group) ) + ;;((eq key :suppress) (setq suppress val)) + (t (message "Uknown argument %s in defmap" key)))) + (setq args (cddr args))) + (unless (keymapp m) + (setq bs (append m bs)) + (setq m (if dense (make-keymap) (make-sparse-keymap)))) + (dolist (b bs) + (let ((keys (car b)) + (binding (cdr b))) + (dolist (key (if (consp keys) keys (list keys))) + (cond + ((symbolp key) + (substitute-key-definition key binding m global-map)) + ((null binding) + (unless (keymapp (lookup-key m key)) (define-key m key binding))) + ((let ((o (lookup-key m key))) + (or (null o) (numberp o) (eq o 'undefined))) + (define-key m key binding)))))) + (cond + ((keymapp inherit) (set-keymap-parent m inherit)) + ((consp inherit) (set-keymap-parents m inherit))) + m)) + +(defmacro defmap (m bs doc &rest args) + `(defconst ,m + (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args)) + ,doc)) + +;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun custom-create-syntax (css args) + (let ((st (make-syntax-table (cadr (memq :copy args))))) + (dolist (cs css) + (let ((char (car cs)) + (syntax (cdr cs))) + (if (sequencep char) + (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char) + (modify-syntax-entry char syntax st)))) + st)) + +(defmacro defsyntax (st css doc &rest args) + `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc)) + +;;;; +;;;; Compatibility info +;;;; + +(defvar urweb-builtin-nested-comments-flag + (ignore-errors + (not (equal (let ((st (make-syntax-table))) + (modify-syntax-entry ?\* ". 23n" st) st) + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\* ". 23" st) st)))) + "Non-nil means this Emacs understands the `n' in syntax entries.") + +(provide 'urweb-util) + +;;; urweb-util.el ends here
--- a/tests/crud1.ur Sat Oct 04 20:05:50 2008 -0400 +++ b/tests/crud1.ur Sun Oct 12 10:04:17 2008 -0400 @@ -1,42 +1,36 @@ table t1 : {Id : int, A : int, B : string, C : float, D : bool} open Crud.Make(struct - val tab = t1 - - val title = "Crud1" - - val cols = { - A = { - Nam = "A", - Show = txt _, - Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, - WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>, - Parse = readError _, - Inject = _ - }, - B = { - Nam = "B", - Show = txt _, - Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, - WidgetPopulated = fn (nm :: Name) s => <lform><textbox{nm} value={s}/></lform>, - Parse = readError _, - Inject = _ - }, - C = { - Nam = "C", - Show = txt _, - Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, - WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>, - Parse = readError _, - Inject = _ - }, - D = { - Nam = "D", - Show = txt _, - Widget = fn nm :: Name => <lform><checkbox{nm}/></lform>, - WidgetPopulated = fn (nm :: Name) b => <lform><checkbox{nm} checked={b}/></lform>, - Parse = fn x => x, - Inject = _ - } - } -end) + val tab = t1 + + val title = "Crud1" + + val cols = { + A = {Nam = "A", + Show = txt _, + Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, + WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>, + Parse = readError _, + Inject = _}, + B = {Nam = "B", + Show = txt _, + Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, + WidgetPopulated = fn (nm :: Name) s => <lform><textbox{nm} value={s}/></lform>, + Parse = readError _, + Inject = _ + }, + C = {Nam = "C", + Show = txt _, + Widget = fn nm :: Name => <lform><textbox{nm}/></lform>, + WidgetPopulated = fn (nm :: Name) n => <lform><textbox{nm} value={show _ n}/></lform>, + Parse = readError _, + Inject = _ + }, + D = {Nam = "D", + Show = txt _, + Widget = fn nm :: Name => <lform><checkbox{nm}/></lform>, + WidgetPopulated = fn (nm :: Name) b => <lform><checkbox{nm} checked={b}/></lform>, + Parse = fn x => x, + Inject = _} + } + end)