Mercurial > urweb

annotate src/elisp/urweb-move.el @ 953:301530da2062

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Bad sort functions tested
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Sep 2009 14:57:38 -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