Mercurial > urweb

annotate src/elisp/urweb-move.el @ 1244:1eedc9086e6c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use key information in more places, and catch cases where one key completion depends on another having happened already
author Adam Chlipala <adamc@hcoop.net>
date Sun, 18 Apr 2010 13:00:36 -0400
parents 4083d0dff94c
children
rev   line source
adamc@350 1 ;;; urweb-move.el --- Buffer navigation functions for urweb-mode
adamc@350 2
adamc@350 3 ;; Based on urweb-mode:
adamc@350 4 ;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org>
adamc@350 5 ;;
adamc@350 6 ;; Modified for urweb-mode:
adamc@350 7 ;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net>
adamc@350 8 ;;
adamc@350 9 ;; This program is free software; you can redistribute it and/or modify
adamc@350 10 ;; it under the terms of the GNU General Public License as published by
adamc@350 11 ;; the Free Software Foundation; either version 2 of the License, or
adamc@350 12 ;; (at your option) any later version.
adamc@350 13 ;;
adamc@350 14 ;; This program is distributed in the hope that it will be useful,
adamc@350 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
adamc@350 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
adamc@350 17 ;; GNU General Public License for more details.
adamc@350 18 ;;
adamc@350 19 ;; You should have received a copy of the GNU General Public License
adamc@350 20 ;; along with this program; if not, write to the Free Software
adamc@350 21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
adamc@350 22
adamc@350 23
adamc@350 24 ;;; Commentary:
adamc@350 25
adamc@350 26
adamc@350 27 ;;; Code:
adamc@350 28
adamc@350 29 (eval-when-compile (require 'cl))
adamc@350 30 (require 'urweb-util)
adamc@350 31 (require 'urweb-defs)
adamc@350 32
adamc@350 33 (defsyntax urweb-internal-syntax-table
adamc@350 34 '((?_ . "w")
adamc@350 35 (?' . "w")
adamc@350 36 (?. . "w"))
adamc@350 37 "Syntax table used for internal urweb-mode operation."
adamc@350 38 :copy urweb-mode-syntax-table)
adamc@350 39
adamc@350 40 ;;;
adamc@350 41 ;;; various macros
adamc@350 42 ;;;
adamc@350 43
adamc@350 44 (defmacro urweb-with-ist (&rest r)
adamc@350 45 (let ((ost-sym (make-symbol "oldtable")))
adamc@350 46 `(let ((,ost-sym (syntax-table))
adamc@350 47 (case-fold-search nil)
adamc@350 48 (parse-sexp-lookup-properties t)
adamc@350 49 (parse-sexp-ignore-comments t))
adamc@350 50 (unwind-protect
adamc@350 51 (progn (set-syntax-table urweb-internal-syntax-table) . ,r)
adamc@350 52 (set-syntax-table ,ost-sym)))))
adamc@350 53 (def-edebug-spec urweb-with-ist t)
adamc@350 54
adamc@350 55 (defmacro urweb-move-if (&rest body)
adamc@350 56 (let ((pt-sym (make-symbol "point"))
adamc@350 57 (res-sym (make-symbol "result")))
adamc@350 58 `(let ((,pt-sym (point))
adamc@350 59 (,res-sym ,(cons 'progn body)))
adamc@350 60 (unless ,res-sym (goto-char ,pt-sym))
adamc@350 61 ,res-sym)))
adamc@350 62 (def-edebug-spec urweb-move-if t)
adamc@350 63
adamc@350 64 (defmacro urweb-point-after (&rest body)
adamc@350 65 `(save-excursion
adamc@350 66 ,@body
adamc@350 67 (point)))
adamc@350 68 (def-edebug-spec urweb-point-after t)
adamc@350 69
adamc@350 70 ;;
adamc@350 71
adamc@350 72 (defvar urweb-op-prec
adamc@350 73 (urweb-preproc-alist
adamc@350 74 '((("UNION" "INTERSECT" "EXCEPT") . 0)
adamc@350 75 (("AND" "OR") . 1)
adamc@368 76 ((">=" "<>" "<=" "=") . 4)
adamc@350 77 (("+" "-" "^") . 6)
adamc@369 78 (("*" "%") . 7)
adamc@354 79 (("NOT") 9)))
adamc@350 80 "Alist of Ur/Web infix operators and their precedence.")
adamc@350 81
adamc@350 82 (defconst urweb-syntax-prec
adamc@350 83 (urweb-preproc-alist
adamc@836 84 `(("," . 20)
adamc@350 85 (("=>" "d=" "=of") . (65 . 40))
adamc@350 86 ("|" . (47 . 30))
adamc@350 87 (("case" "of" "fn") . 45)
adamc@350 88 (("if" "then" "else" ) . 50)
adamc@836 89 (";" . 53)
adamc@350 90 (("<-") . 55)
adamc@350 91 ("||" . 70)
adamc@350 92 ("&&" . 80)
adamc@354 93 ((":" ":>") . 90)
adamc@350 94 ("->" . 95)
adamc@350 95 ("with" . 100)
adamc@350 96 (,(cons "end" urweb-begin-syms) . 10000)))
adamc@350 97 "Alist of pseudo-precedence of syntactic elements.")
adamc@350 98
adamc@350 99 (defun urweb-op-prec (op dir)
adamc@350 100 "Return the precedence of OP or nil if it's not an infix.
adamc@350 101 DIR should be set to BACK if you want to precedence w.r.t the left side
adamc@350 102 and to FORW for the precedence w.r.t the right side.
adamc@350 103 This assumes that we are `looking-at' the OP."
adamc@350 104 (when op
adamc@350 105 (let ((sprec (cdr (assoc op urweb-syntax-prec))))
adamc@350 106 (cond
adamc@350 107 ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec)))
adamc@350 108 (sprec sprec)
adamc@350 109 (t
adamc@350 110 (let ((prec (cdr (assoc op urweb-op-prec))))
adamc@350 111 (when prec (+ prec 100))))))))
adamc@350 112
adamc@350 113 ;;
adamc@350 114
adamc@350 115 (defun urweb-forward-spaces () (forward-comment 100000))
adamc@350 116 (defun urweb-backward-spaces () (forward-comment -100000))
adamc@350 117
adamc@350 118
adamc@350 119 ;;
adamc@350 120 ;; moving forward around matching symbols
adamc@350 121 ;;
adamc@350 122
adamc@350 123 (defun urweb-looking-back-at (re)
adamc@350 124 (save-excursion
adamc@350 125 (when (= 0 (skip-syntax-backward "w_")) (backward-char))
adamc@350 126 (looking-at re)))
adamc@350 127
adamc@350 128 (defun urweb-find-match-forward (this match)
adamc@350 129 "Only works for word matches."
adamc@350 130 (let ((level 1)
adamc@350 131 (forward-sexp-function nil)
adamc@350 132 (either (concat this "\\|" match)))
adamc@350 133 (while (> level 0)
adamc@350 134 (forward-sexp 1)
adamc@350 135 (while (not (or (eobp) (urweb-looking-back-at either)))
adamc@350 136 (condition-case () (forward-sexp 1) (error (forward-char 1))))
adamc@350 137 (setq level
adamc@350 138 (cond
adamc@350 139 ((and (eobp) (> level 1)) (error "Unbalanced"))
adamc@350 140 ((urweb-looking-back-at this) (1+ level))
adamc@350 141 ((urweb-looking-back-at match) (1- level))
adamc@350 142 (t (error "Unbalanced")))))
adamc@350 143 t))
adamc@350 144
adamc@350 145 (defun urweb-find-match-backward (this match)
adamc@350 146 (let ((level 1)
adamc@350 147 (forward-sexp-function nil)
adamc@350 148 (either (concat this "\\|" match)))
adamc@350 149 (while (> level 0)
adamc@350 150 (backward-sexp 1)
adamc@350 151 (while (not (or (bobp) (looking-at either)))
adamc@350 152 (condition-case () (backward-sexp 1) (error (backward-char 1))))
adamc@350 153 (setq level
adamc@350 154 (cond
adamc@350 155 ((and (bobp) (> level 1)) (error "Unbalanced"))
adamc@350 156 ((looking-at this) (1+ level))
adamc@350 157 ((looking-at match) (1- level))
adamc@350 158 (t (error "Unbalanced")))))
adamc@350 159 t))
adamc@350 160
adamc@350 161 ;;;
adamc@350 162 ;;; read a symbol, including the special "op <sym>" case
adamc@350 163 ;;;
adamc@350 164
adamc@350 165 (defmacro urweb-move-read (&rest body)
adamc@350 166 (let ((pt-sym (make-symbol "point")))
adamc@350 167 `(let ((,pt-sym (point)))
adamc@350 168 ,@body
adamc@350 169 (when (/= (point) ,pt-sym)
adamc@350 170 (buffer-substring-no-properties (point) ,pt-sym)))))
adamc@350 171 (def-edebug-spec urweb-move-read t)
adamc@350 172
adamc@350 173 (defun urweb-poly-equal-p ()
adamc@350 174 (< (urweb-point-after (re-search-backward urweb-=-starter-re nil 'move))
adamc@350 175 (urweb-point-after (re-search-backward "=" nil 'move))))
adamc@350 176
adamc@350 177 (defun urweb-nested-of-p ()
adamc@350 178 (< (urweb-point-after
adamc@350 179 (re-search-backward urweb-non-nested-of-starter-re nil 'move))
adamc@350 180 (urweb-point-after (re-search-backward "\\<case\\>" nil 'move))))
adamc@350 181
adamc@350 182 (defun urweb-forward-sym-1 ()
adamc@350 183 (or (/= 0 (skip-syntax-forward "'w_"))
adamc@350 184 (/= 0 (skip-syntax-forward ".'"))))
adamc@350 185 (defun urweb-forward-sym ()
adamc@371 186 (interactive)
adamc@350 187 (let ((sym (urweb-move-read (urweb-forward-sym-1))))
adamc@350 188 (cond
adamc@350 189 ((equal "op" sym)
adamc@350 190 (urweb-forward-spaces)
adamc@350 191 (concat "op " (or (urweb-move-read (urweb-forward-sym-1)) "")))
adamc@350 192 ((equal sym "=")
adamc@350 193 (save-excursion
adamc@350 194 (urweb-backward-sym-1)
adamc@350 195 (if (urweb-poly-equal-p) "=" "d=")))
adamc@350 196 ((equal sym "of")
adamc@350 197 (save-excursion
adamc@350 198 (urweb-backward-sym-1)
adamc@350 199 (if (urweb-nested-of-p) "of" "=of")))
adamc@350 200 ;; ((equal sym "datatype")
adamc@350 201 ;; (save-excursion
adamc@350 202 ;; (urweb-backward-sym-1)
adamc@350 203 ;; (urweb-backward-spaces)
adamc@350 204 ;; (if (eq (preceding-char) ?=) "=datatype" sym)))
adamc@350 205 (t sym))))
adamc@350 206
adamc@350 207 (defun urweb-backward-sym-1 ()
adamc@350 208 (or (/= 0 (skip-syntax-backward ".'"))
adamc@350 209 (/= 0 (skip-syntax-backward "'w_"))))
adamc@350 210 (defun urweb-backward-sym ()
adamc@371 211 (interactive)
adamc@350 212 (let ((sym (urweb-move-read (urweb-backward-sym-1))))
adamc@371 213 (let ((result
adamc@371 214 (when sym
adamc@371 215 ;; FIXME: what should we do if `sym' = "op" ?
adamc@371 216 (let ((point (point)))
adamc@371 217 (urweb-backward-spaces)
adamc@371 218 (if (equal "op" (urweb-move-read (urweb-backward-sym-1)))
adamc@371 219 (concat "op " sym)
adamc@371 220 (goto-char point)
adamc@371 221 (cond
adamc@371 222 ((string= sym "=") (if (urweb-poly-equal-p) "=" "d="))
adamc@371 223 ((string= sym "of") (if (urweb-nested-of-p) "of" "=of"))
adamc@371 224 ;; ((string= sym "datatype")
adamc@371 225 ;; (save-excursion (urweb-backward-spaces)
adamc@371 226 ;; (if (eq (preceding-char) ?=) "=datatype" sym)))
adamc@371 227 (t sym)))))))
adamc@371 228 (if (looking-at ">")
adamc@371 229 (substring result 1 nil)
adamc@371 230 result))))
adamc@371 231 ;; (if (save-excursion (backward-char 5) (looking-at "</xml>"))
adamc@371 232 ;; (progn
adamc@371 233 ;; (backward-char 5)
adamc@371 234 ;; (urweb-tag-matcher)
adamc@371 235 ;; (backward-char)
adamc@371 236 ;; (urweb-backward-sym))
adamc@371 237 ;; result))))
adamc@350 238
adamc@368 239 (defun urweb-tag-matcher ()
adamc@368 240 "Seek back to a matching opener tag"
adamc@368 241 (let ((depth 0)
adamc@368 242 (done nil))
adamc@368 243 (while (and (not done) (search-backward ">" nil t))
adamc@396 244 (cond
adamc@396 245 ((save-excursion (backward-char 1) (looking-at " "))
adamc@396 246 nil)
adamc@396 247 ((save-excursion (backward-char 1) (looking-at "/"))
adamc@396 248 (when (not (re-search-backward "<[^ =]" nil t))
adamc@396 249 (setq done t)))
adamc@396 250 (t
adamc@396 251 (if (re-search-backward "<[^ =]" nil t)
adamc@368 252 (if (looking-at "</")
adamc@368 253 (incf depth)
adamc@368 254 (if (= depth 0)
adamc@368 255 (setq done t)
adamc@368 256 (decf depth)))
adamc@396 257 (setq done t)))))))
adamc@368 258
adamc@350 259 (defun urweb-backward-sexp (prec)
adamc@350 260 "Move one sexp backward if possible, or one char else.
adamc@350 261 Returns t if the move indeed moved through one sexp and nil if not.
adamc@350 262 PREC is the precedence currently looked for."
adamc@371 263 (let ((result (let ((parse-sexp-lookup-properties t)
adamc@371 264 (parse-sexp-ignore-comments t))
adamc@371 265 (urweb-backward-spaces)
adamc@371 266 (let* ((op (urweb-backward-sym))
adamc@371 267 (op-prec (urweb-op-prec op 'back))
adamc@371 268 match)
adamc@371 269 (cond
adamc@371 270 ((not op)
adamc@371 271 (let ((point (point)))
adamc@371 272 (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1)))
adamc@371 273 (if (/= point (point)) t (ignore-errors (backward-char 1)) nil)))
adamc@371 274 ;; stop as soon as precedence is smaller than `prec'
adamc@371 275 ((and prec op-prec (>= prec op-prec)) nil)
adamc@371 276 ;; special rules for nested constructs like if..then..else
adamc@371 277 ((and (or (not prec) (and prec op-prec))
adamc@371 278 (setq match (second (assoc op urweb-close-paren))))
adamc@371 279 (urweb-find-match-backward (concat "\\<" op "\\>") match))
adamc@371 280 ;; don't back over open-parens
adamc@371 281 ((assoc op urweb-open-paren) nil)
adamc@371 282 ;; infix ops precedence
adamc@371 283 ((and prec op-prec) (< prec op-prec))
adamc@371 284 ;; [ prec = nil ] a new operator, let's skip the sexps until the next
adamc@371 285 (op-prec (while (urweb-move-if (urweb-backward-sexp op-prec))) t)
adamc@371 286 ;; special symbols indicating we're getting out of a nesting level
adamc@371 287 ((string-match urweb-sexp-head-symbols-re op) nil)
adamc@371 288 ;; if the op was not alphanum, then we still have to do the backward-sexp
adamc@371 289 ;; this reproduces the usual backward-sexp, but it might be bogus
adamc@371 290 ;; in this case since !@$% is a perfectly fine symbol
adamc@371 291 (t t))))))
adamc@371 292 (if (save-excursion (backward-char 5) (looking-at "</xml>"))
adamc@371 293 (progn
adamc@371 294 (backward-char 5)
adamc@371 295 (urweb-tag-matcher)
adamc@371 296 (backward-char)
adamc@371 297 (urweb-backward-sexp prec))
adamc@371 298 result)))
adamc@350 299
adamc@350 300 (defun urweb-forward-sexp (prec)
adamc@350 301 "Moves one sexp forward if possible, or one char else.
adamc@350 302 Returns T if the move indeed moved through one sexp and NIL if not."
adamc@350 303 (let ((parse-sexp-lookup-properties t)
adamc@350 304 (parse-sexp-ignore-comments t))
adamc@350 305 (urweb-forward-spaces)
adamc@350 306 (let* ((op (urweb-forward-sym))
adamc@350 307 (op-prec (urweb-op-prec op 'forw))
adamc@350 308 match)
adamc@350 309 (cond
adamc@350 310 ((not op)
adamc@350 311 (let ((point (point)))
adamc@350 312 (ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1)))
adamc@350 313 (if (/= point (point)) t (forward-char 1) nil)))
adamc@350 314 ;; stop as soon as precedence is smaller than `prec'
adamc@350 315 ((and prec op-prec (>= prec op-prec)) nil)
adamc@350 316 ;; special rules for nested constructs like if..then..else
adamc@350 317 ((and (or (not prec) (and prec op-prec))
adamc@350 318 (setq match (cdr (assoc op urweb-open-paren))))
adamc@350 319 (urweb-find-match-forward (first match) (second match)))
adamc@350 320 ;; don't forw over close-parens
adamc@350 321 ((assoc op urweb-close-paren) nil)
adamc@350 322 ;; infix ops precedence
adamc@350 323 ((and prec op-prec) (< prec op-prec))
adamc@350 324 ;; [ prec = nil ] a new operator, let's skip the sexps until the next
adamc@350 325 (op-prec (while (urweb-move-if (urweb-forward-sexp op-prec))) t)
adamc@350 326 ;; special symbols indicating we're getting out of a nesting level
adamc@350 327 ((string-match urweb-sexp-head-symbols-re op) nil)
adamc@350 328 ;; if the op was not alphanum, then we still have to do the backward-sexp
adamc@350 329 ;; this reproduces the usual backward-sexp, but it might be bogus
adamc@350 330 ;; in this case since !@$% is a perfectly fine symbol
adamc@350 331 (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec))
adamc@350 332
adamc@350 333 (defun urweb-in-word-p ()
adamc@350 334 (and (eq ?w (char-syntax (or (char-before) ? )))
adamc@350 335 (eq ?w (char-syntax (or (char-after) ? )))))
adamc@350 336
adamc@350 337 (defun urweb-user-backward-sexp (&optional count)
adamc@350 338 "Like `backward-sexp' but tailored to the Ur/Web syntax."
adamc@350 339 (interactive "p")
adamc@350 340 (unless count (setq count 1))
adamc@350 341 (urweb-with-ist
adamc@350 342 (let ((point (point)))
adamc@350 343 (if (< count 0) (urweb-user-forward-sexp (- count))
adamc@350 344 (when (urweb-in-word-p) (forward-word 1))
adamc@350 345 (dotimes (i count)
adamc@350 346 (unless (urweb-backward-sexp nil)
adamc@350 347 (goto-char point)
adamc@350 348 (error "Containing expression ends prematurely")))))))
adamc@350 349
adamc@368 350
adamc@350 351 (defun urweb-user-forward-sexp (&optional count)
adamc@350 352 "Like `forward-sexp' but tailored to the Ur/Web syntax."
adamc@350 353 (interactive "p")
adamc@350 354 (unless count (setq count 1))
adamc@350 355 (urweb-with-ist
adamc@350 356 (let ((point (point)))
adamc@350 357 (if (< count 0) (urweb-user-backward-sexp (- count))
adamc@350 358 (when (urweb-in-word-p) (backward-word 1))
adamc@350 359 (dotimes (i count)
adamc@350 360 (unless (urweb-forward-sexp nil)
adamc@350 361 (goto-char point)
adamc@350 362 (error "Containing expression ends prematurely")))))))
adamc@350 363
adamc@350 364 ;;(defun urweb-forward-thing ()
adamc@350 365 ;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1)))
adamc@350 366
adamc@371 367 (defun urweb-backward-arg () (interactive) (urweb-backward-sexp 1000))
adamc@371 368 (defun urweb-forward-arg () (interactive) (urweb-forward-sexp 1000))
adamc@350 369
adamc@350 370
adamc@350 371 (provide 'urweb-move)
adamc@350 372
adamc@350 373 ;;; urweb-move.el ends here