adamc@350: ;;; urweb-move.el --- Buffer navigation functions for urweb-mode adamc@350: adamc@350: ;; Based on urweb-mode: adamc@350: ;; Copyright (C) 1999, 2000, 2004 Stefan Monnier adamc@350: ;; adamc@350: ;; Modified for urweb-mode: adamc@350: ;; Copyright (C) 2008 Adam Chlipala adamc@350: ;; adamc@350: ;; This program is free software; you can redistribute it and/or modify adamc@350: ;; it under the terms of the GNU General Public License as published by adamc@350: ;; the Free Software Foundation; either version 2 of the License, or adamc@350: ;; (at your option) any later version. adamc@350: ;; adamc@350: ;; This program is distributed in the hope that it will be useful, adamc@350: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of adamc@350: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the adamc@350: ;; GNU 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 this program; if not, write to the Free Software adamc@350: ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. adamc@350: adamc@350: adamc@350: ;;; Commentary: adamc@350: adamc@350: adamc@350: ;;; Code: adamc@350: adamc@350: (eval-when-compile (require 'cl)) adamc@350: (require 'urweb-util) adamc@350: (require 'urweb-defs) adamc@350: adamc@350: (defsyntax urweb-internal-syntax-table adamc@350: '((?_ . "w") adamc@350: (?' . "w") adamc@350: (?. . "w")) adamc@350: "Syntax table used for internal urweb-mode operation." adamc@350: :copy urweb-mode-syntax-table) adamc@350: adamc@350: ;;; adamc@350: ;;; various macros adamc@350: ;;; adamc@350: adamc@350: (defmacro urweb-with-ist (&rest r) adamc@350: (let ((ost-sym (make-symbol "oldtable"))) adamc@350: `(let ((,ost-sym (syntax-table)) adamc@350: (case-fold-search nil) adamc@350: (parse-sexp-lookup-properties t) adamc@350: (parse-sexp-ignore-comments t)) adamc@350: (unwind-protect adamc@350: (progn (set-syntax-table urweb-internal-syntax-table) . ,r) adamc@350: (set-syntax-table ,ost-sym))))) adamc@350: (def-edebug-spec urweb-with-ist t) adamc@350: adamc@350: (defmacro urweb-move-if (&rest body) adamc@350: (let ((pt-sym (make-symbol "point")) adamc@350: (res-sym (make-symbol "result"))) adamc@350: `(let ((,pt-sym (point)) adamc@350: (,res-sym ,(cons 'progn body))) adamc@350: (unless ,res-sym (goto-char ,pt-sym)) adamc@350: ,res-sym))) adamc@350: (def-edebug-spec urweb-move-if t) adamc@350: adamc@350: (defmacro urweb-point-after (&rest body) adamc@350: `(save-excursion adamc@350: ,@body adamc@350: (point))) adamc@350: (def-edebug-spec urweb-point-after t) adamc@350: adamc@350: ;; adamc@350: adamc@350: (defvar urweb-op-prec adamc@350: (urweb-preproc-alist adamc@350: '((("UNION" "INTERSECT" "EXCEPT") . 0) adamc@350: (("AND" "OR") . 1) adamc@350: ((">" ">=" "<>" "<" "<=" "=") . 4) adamc@350: (("+" "-" "^") . 6) adamc@350: (("/" "*" "%") . 7) adamc@350: (("++" "--") 8) adamc@350: (("NOT") 9) adamc@353: (("~") 10))) adamc@350: "Alist of Ur/Web infix operators and their precedence.") adamc@350: adamc@350: (defconst urweb-syntax-prec adamc@350: (urweb-preproc-alist adamc@350: `(((";" ",") . 20) adamc@350: (("=>" "d=" "=of") . (65 . 40)) adamc@350: ("|" . (47 . 30)) adamc@350: (("case" "of" "fn") . 45) adamc@350: (("if" "then" "else" ) . 50) adamc@350: (("<-") . 55) adamc@350: ("||" . 70) adamc@350: ("&&" . 80) adamc@350: ((":" "::" ":::" ":>") . 90) adamc@350: ("->" . 95) adamc@350: ("with" . 100) adamc@350: (,(cons "end" urweb-begin-syms) . 10000))) adamc@350: "Alist of pseudo-precedence of syntactic elements.") adamc@350: adamc@350: (defun urweb-op-prec (op dir) adamc@350: "Return the precedence of OP or nil if it's not an infix. adamc@350: DIR should be set to BACK if you want to precedence w.r.t the left side adamc@350: and to FORW for the precedence w.r.t the right side. adamc@350: This assumes that we are `looking-at' the OP." adamc@350: (when op adamc@350: (let ((sprec (cdr (assoc op urweb-syntax-prec)))) adamc@350: (cond adamc@350: ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec))) adamc@350: (sprec sprec) adamc@350: (t adamc@350: (let ((prec (cdr (assoc op urweb-op-prec)))) adamc@350: (when prec (+ prec 100)))))))) adamc@350: adamc@350: ;; adamc@350: adamc@350: (defun urweb-forward-spaces () (forward-comment 100000)) adamc@350: (defun urweb-backward-spaces () (forward-comment -100000)) adamc@350: adamc@350: adamc@350: ;; adamc@350: ;; moving forward around matching symbols adamc@350: ;; adamc@350: adamc@350: (defun urweb-looking-back-at (re) adamc@350: (save-excursion adamc@350: (when (= 0 (skip-syntax-backward "w_")) (backward-char)) adamc@350: (looking-at re))) adamc@350: adamc@350: (defun urweb-find-match-forward (this match) adamc@350: "Only works for word matches." adamc@350: (let ((level 1) adamc@350: (forward-sexp-function nil) adamc@350: (either (concat this "\\|" match))) adamc@350: (while (> level 0) adamc@350: (forward-sexp 1) adamc@350: (while (not (or (eobp) (urweb-looking-back-at either))) adamc@350: (condition-case () (forward-sexp 1) (error (forward-char 1)))) adamc@350: (setq level adamc@350: (cond adamc@350: ((and (eobp) (> level 1)) (error "Unbalanced")) adamc@350: ((urweb-looking-back-at this) (1+ level)) adamc@350: ((urweb-looking-back-at match) (1- level)) adamc@350: (t (error "Unbalanced"))))) adamc@350: t)) adamc@350: adamc@350: (defun urweb-find-match-backward (this match) adamc@350: (let ((level 1) adamc@350: (forward-sexp-function nil) adamc@350: (either (concat this "\\|" match))) adamc@350: (while (> level 0) adamc@350: (backward-sexp 1) adamc@350: (while (not (or (bobp) (looking-at either))) adamc@350: (condition-case () (backward-sexp 1) (error (backward-char 1)))) adamc@350: (setq level adamc@350: (cond adamc@350: ((and (bobp) (> level 1)) (error "Unbalanced")) adamc@350: ((looking-at this) (1+ level)) adamc@350: ((looking-at match) (1- level)) adamc@350: (t (error "Unbalanced"))))) adamc@350: t)) adamc@350: adamc@350: ;;; adamc@350: ;;; read a symbol, including the special "op " case adamc@350: ;;; adamc@350: adamc@350: (defmacro urweb-move-read (&rest body) adamc@350: (let ((pt-sym (make-symbol "point"))) adamc@350: `(let ((,pt-sym (point))) adamc@350: ,@body adamc@350: (when (/= (point) ,pt-sym) adamc@350: (buffer-substring-no-properties (point) ,pt-sym))))) adamc@350: (def-edebug-spec urweb-move-read t) adamc@350: adamc@350: (defun urweb-poly-equal-p () adamc@350: (< (urweb-point-after (re-search-backward urweb-=-starter-re nil 'move)) adamc@350: (urweb-point-after (re-search-backward "=" nil 'move)))) adamc@350: adamc@350: (defun urweb-nested-of-p () adamc@350: (< (urweb-point-after adamc@350: (re-search-backward urweb-non-nested-of-starter-re nil 'move)) adamc@350: (urweb-point-after (re-search-backward "\\" nil 'move)))) adamc@350: adamc@350: (defun urweb-forward-sym-1 () adamc@350: (or (/= 0 (skip-syntax-forward "'w_")) adamc@350: (/= 0 (skip-syntax-forward ".'")))) adamc@350: (defun urweb-forward-sym () adamc@350: (let ((sym (urweb-move-read (urweb-forward-sym-1)))) adamc@350: (cond adamc@350: ((equal "op" sym) adamc@350: (urweb-forward-spaces) adamc@350: (concat "op " (or (urweb-move-read (urweb-forward-sym-1)) ""))) adamc@350: ((equal sym "=") adamc@350: (save-excursion adamc@350: (urweb-backward-sym-1) adamc@350: (if (urweb-poly-equal-p) "=" "d="))) adamc@350: ((equal sym "of") adamc@350: (save-excursion adamc@350: (urweb-backward-sym-1) adamc@350: (if (urweb-nested-of-p) "of" "=of"))) adamc@350: ;; ((equal sym "datatype") adamc@350: ;; (save-excursion adamc@350: ;; (urweb-backward-sym-1) adamc@350: ;; (urweb-backward-spaces) adamc@350: ;; (if (eq (preceding-char) ?=) "=datatype" sym))) adamc@350: (t sym)))) adamc@350: adamc@350: (defun urweb-backward-sym-1 () adamc@350: (or (/= 0 (skip-syntax-backward ".'")) adamc@350: (/= 0 (skip-syntax-backward "'w_")))) adamc@350: (defun urweb-backward-sym () adamc@350: (let ((sym (urweb-move-read (urweb-backward-sym-1)))) adamc@350: (when sym adamc@350: ;; FIXME: what should we do if `sym' = "op" ? adamc@350: (let ((point (point))) adamc@350: (urweb-backward-spaces) adamc@350: (if (equal "op" (urweb-move-read (urweb-backward-sym-1))) adamc@350: (concat "op " sym) adamc@350: (goto-char point) adamc@350: (cond adamc@350: ((string= sym "=") (if (urweb-poly-equal-p) "=" "d=")) adamc@350: ((string= sym "of") (if (urweb-nested-of-p) "of" "=of")) adamc@350: ;; ((string= sym "datatype") adamc@350: ;; (save-excursion (urweb-backward-spaces) adamc@350: ;; (if (eq (preceding-char) ?=) "=datatype" sym))) adamc@350: (t sym))))))) adamc@350: adamc@350: adamc@350: (defun urweb-backward-sexp (prec) adamc@350: "Move one sexp backward if possible, or one char else. adamc@350: Returns t if the move indeed moved through one sexp and nil if not. adamc@350: PREC is the precedence currently looked for." adamc@350: (let ((parse-sexp-lookup-properties t) adamc@350: (parse-sexp-ignore-comments t)) adamc@350: (urweb-backward-spaces) adamc@350: (let* ((op (urweb-backward-sym)) adamc@350: (op-prec (urweb-op-prec op 'back)) adamc@350: match) adamc@350: (cond adamc@350: ((not op) adamc@350: (let ((point (point))) adamc@350: (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1))) adamc@350: (if (/= point (point)) t (ignore-errors (backward-char 1)) nil))) adamc@350: ;; stop as soon as precedence is smaller than `prec' adamc@350: ((and prec op-prec (>= prec op-prec)) nil) adamc@350: ;; special rules for nested constructs like if..then..else adamc@350: ((and (or (not prec) (and prec op-prec)) adamc@350: (setq match (second (assoc op urweb-close-paren)))) adamc@350: (urweb-find-match-backward (concat "\\<" op "\\>") match)) adamc@350: ;; don't back over open-parens adamc@350: ((assoc op urweb-open-paren) nil) adamc@350: ;; infix ops precedence adamc@350: ((and prec op-prec) (< prec op-prec)) adamc@350: ;; [ prec = nil ] a new operator, let's skip the sexps until the next adamc@350: (op-prec (while (urweb-move-if (urweb-backward-sexp op-prec))) t) adamc@350: ;; special symbols indicating we're getting out of a nesting level adamc@350: ((string-match urweb-sexp-head-symbols-re op) nil) adamc@350: ;; if the op was not alphanum, then we still have to do the backward-sexp adamc@350: ;; this reproduces the usual backward-sexp, but it might be bogus adamc@350: ;; in this case since !@$% is a perfectly fine symbol adamc@350: (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) adamc@350: adamc@350: (defun urweb-forward-sexp (prec) adamc@350: "Moves one sexp forward if possible, or one char else. adamc@350: Returns T if the move indeed moved through one sexp and NIL if not." adamc@350: (let ((parse-sexp-lookup-properties t) adamc@350: (parse-sexp-ignore-comments t)) adamc@350: (urweb-forward-spaces) adamc@350: (let* ((op (urweb-forward-sym)) adamc@350: (op-prec (urweb-op-prec op 'forw)) adamc@350: match) adamc@350: (cond adamc@350: ((not op) adamc@350: (let ((point (point))) adamc@350: (ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1))) adamc@350: (if (/= point (point)) t (forward-char 1) nil))) adamc@350: ;; stop as soon as precedence is smaller than `prec' adamc@350: ((and prec op-prec (>= prec op-prec)) nil) adamc@350: ;; special rules for nested constructs like if..then..else adamc@350: ((and (or (not prec) (and prec op-prec)) adamc@350: (setq match (cdr (assoc op urweb-open-paren)))) adamc@350: (urweb-find-match-forward (first match) (second match))) adamc@350: ;; don't forw over close-parens adamc@350: ((assoc op urweb-close-paren) nil) adamc@350: ;; infix ops precedence adamc@350: ((and prec op-prec) (< prec op-prec)) adamc@350: ;; [ prec = nil ] a new operator, let's skip the sexps until the next adamc@350: (op-prec (while (urweb-move-if (urweb-forward-sexp op-prec))) t) adamc@350: ;; special symbols indicating we're getting out of a nesting level adamc@350: ((string-match urweb-sexp-head-symbols-re op) nil) adamc@350: ;; if the op was not alphanum, then we still have to do the backward-sexp adamc@350: ;; this reproduces the usual backward-sexp, but it might be bogus adamc@350: ;; in this case since !@$% is a perfectly fine symbol adamc@350: (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) adamc@350: adamc@350: (defun urweb-in-word-p () adamc@350: (and (eq ?w (char-syntax (or (char-before) ? ))) adamc@350: (eq ?w (char-syntax (or (char-after) ? ))))) adamc@350: adamc@350: (defun urweb-user-backward-sexp (&optional count) adamc@350: "Like `backward-sexp' but tailored to the Ur/Web syntax." adamc@350: (interactive "p") adamc@350: (unless count (setq count 1)) adamc@350: (urweb-with-ist adamc@350: (let ((point (point))) adamc@350: (if (< count 0) (urweb-user-forward-sexp (- count)) adamc@350: (when (urweb-in-word-p) (forward-word 1)) adamc@350: (dotimes (i count) adamc@350: (unless (urweb-backward-sexp nil) adamc@350: (goto-char point) adamc@350: (error "Containing expression ends prematurely"))))))) adamc@350: adamc@350: (defun urweb-user-forward-sexp (&optional count) adamc@350: "Like `forward-sexp' but tailored to the Ur/Web syntax." adamc@350: (interactive "p") adamc@350: (unless count (setq count 1)) adamc@350: (urweb-with-ist adamc@350: (let ((point (point))) adamc@350: (if (< count 0) (urweb-user-backward-sexp (- count)) adamc@350: (when (urweb-in-word-p) (backward-word 1)) adamc@350: (dotimes (i count) adamc@350: (unless (urweb-forward-sexp nil) adamc@350: (goto-char point) adamc@350: (error "Containing expression ends prematurely"))))))) adamc@350: adamc@350: ;;(defun urweb-forward-thing () adamc@350: ;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1))) adamc@350: adamc@350: (defun urweb-backward-arg () (urweb-backward-sexp 1000)) adamc@350: (defun urweb-forward-arg () (urweb-forward-sexp 1000)) adamc@350: adamc@350: adamc@350: (provide 'urweb-move) adamc@350: adamc@350: ;;; urweb-move.el ends here