Mercurial > urweb

comparison src/elisp/urweb-move.el @ 350:3a1e36b14105

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