1 ;;; mmm-noweb.el --- MMM submode class for Noweb programs
3 ;; Copyright 2003, 2004 Joe Kelsey <joe@zircon.seattle.wa.us>
5 ;; The filling, completion and chunk motion commands either taken
6 ;; directly from or inspired by code in:
7 ;; noweb-mode.el - edit noweb files with GNU Emacs
8 ;; Copyright 1995 by Thorsten.Ohl @ Physik.TH-Darmstadt.de
9 ;; with a little help from Norman Ramsey <norman@bellcore.com>
14 ;; This file is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;; This file is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to
26 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA.
33 ;; This file contains the definition of an MMM Mode submode class for
34 ;; editing Noweb programs.
44 (defvar mmm-noweb-code-mode 'fundamental-mode
45 "*Major mode for editing code chunks.
46 This is set to FUNDAMENTAL-MODE by default, but you might want to change
47 this in the Local Variables section of your file to something more
48 appropriate, like C-MODE, FORTRAN-MODE, or even INDENTED-TEXT-MODE.")
50 (defvar mmm-noweb-quote-mode nil
51 "*Major mode for quoted code chunks within documentation chunks.
52 If nil, defaults to `mmm-noweb-code-mode', which see.")
54 (defvar mmm-noweb-quote-string "quote"
55 "*String used to form quoted code submode region names.
56 See `mmm-noweb-quote'.")
58 (defvar mmm-noweb-quote-number 0
59 "*Starting value appended to `mmm-noweb-quote-string'.
60 See `mmm-noweb-quote'.")
62 (defvar mmm-noweb-narrowing nil
63 "*Narrow the region to the current pair of chunks.")
66 ;;{{{ Support for mmm submode stuff
68 (defun mmm-noweb-chunk (form)
69 "Return the noweb code mode chosen by the user.
70 If the next 100 characters of the buffer contain a string of the form
71 \"-*- MODE -*-\", then return MODE as the chosen mode, otherwise
72 return the value of `mmm-noweb-code-mode'."
73 ;; Look for -*- mode -*- in the first two lines.
74 ;; 120 chars = 40 chars for #! + 80 chars for following line...
75 (if (re-search-forward "-\\*-\\s +\\(\\S-+\\)\\s +-\\*-" (+ (point) 120) t)
76 (let* ((string (match-string-no-properties 1))
77 (modestr (intern (if (string-match "mode\\'" string)
79 (concat string "-mode")))))
80 (or (mmm-ensure-modename modestr)
84 (defun mmm-noweb-quote (form)
85 "Create a unique name for a quoted code region within a documentation chunk."
86 (or mmm-noweb-quote-mode
89 (defun mmm-noweb-quote-name (form)
90 "Create a unique name for a quoted code region within a documentation chunk."
91 (setq mmm-noweb-quote-number (1+ mmm-noweb-quote-number))
92 (concat mmm-noweb-quote-string "-"
93 (number-to-string mmm-noweb-quote-number)))
95 (defun mmm-noweb-chunk-name (form)
96 "Get the chunk name from FRONT-FORM."
97 (string-match "<<\\(.*\\)>>=" form)
98 (match-string-no-properties 1 form))
101 ;;{{{ mmm noweb submode group
103 ;; We assume that the global document mode is latex or whatever, the
104 ;; user wants. This class controls the code chunk submodes. We use
105 ;; match-submode to either return the value in mmm-noweb-code-mode or to
106 ;; look at the first line of the chunk for a submode setting. We reset
107 ;; case-fold-search because chunk names are case sensitive. The front
108 ;; string identifies the chunk name between the <<>>. Since this is
109 ;; done, name-match can use the same functions as save-matches for back.
110 ;; Our insert skeleton places a new code chunk and the skel-name lets us
111 ;; optimize the skelton naming to use the inserted string.
116 :match-submode mmm-noweb-chunk
117 :case-fold-search nil
118 :front "^<<\\(.*\\)>>="
121 :front-offset (end-of-line 1)
122 :back "^@\\( \\|$\\|\\( %def .*$\\)\\)"
123 :insert ((?c noweb-code "Code Chunk Name: "
124 "\n" @ "<<" str ">>=" @ "\n" _ "\n" @ "@ " @ "\n"))
128 :match-submode mmm-noweb-quote
129 :face mmm-special-submode-face
131 ; :name-match mmm-noweb-quote-name
133 :insert ((?q noweb-quote nil @ "[[" @ _ @ "]]" @))
140 (defun mmm-noweb-regions (start stop regexp &optional delim)
141 "Return a liat of regions of the form \(NAME BEG END) that exclude
142 names which match REGEXP."
143 (let* ((remove-next nil)
145 (maplist #'(lambda (pos-list)
148 (setq remove-next nil)
149 (let ((name (or (mmm-name-at (car pos-list) 'beg)
150 (symbol-name mmm-primary-mode))))
151 (if (and regexp (string-match regexp name) )
156 (car pos-list) (cadr pos-list)))))))
157 (mmm-submode-changes-in start stop t delim))))
158 ;; The above loop leaves lots of nils in the list...
159 ;; Removing them saves us from having to do the (last x 2)
160 ;; trick that mmm-regions-in does.
161 (setq regions (delq nil regions))))
166 (defun mmm-noweb-narrow-to-doc-chunk ()
167 "Narrow to the current doc chunk.
168 The current chunk includes all quoted code chunks (i.e., \[\[...\]\]).
169 This function is only valid when called with point in a doc chunk or
172 (let ((name (mmm-name-at (point))))
173 (if (or (null name) (string-match "^quote" name))
175 ((= (point) (point-min)) (point))
176 (t (cadar (last (mmm-noweb-regions (point-min) (point)
179 ((= (point) (point-max)) (point))
182 (cadr (mmm-noweb-regions (point)
187 (narrow-to-region prev next)))))
189 (defun mmm-noweb-fill-chunk (&optional justify)
190 "Fill the current chunk according to mode.
191 Run `fill-region' on documentation chunks and `indent-region' on code
195 (let ((name (mmm-name-at (point))))
196 (if (and name (not (string-match "^quote" name)))
197 (if (or indent-region-function indent-line-function)
199 (mmm-space-other-regions)
200 (indent-region (overlay-start mmm-current-overlay)
201 (overlay-end mmm-current-overlay) nil))
202 (error "No indentation functions defined in %s!" major-mode))
204 (mmm-word-other-regions)
205 (fill-paragraph justify)))
206 (mmm-undo-syntax-other-regions))))
208 (defun mmm-noweb-fill-paragraph-chunk (&optional justify)
209 "Fill a paragraph in the current chunk."
212 (let ((name (mmm-name-at (point))))
213 (if (and name (not (string-match "^quote" name)))
215 (mmm-space-other-regions)
216 (fill-paragraph justify))
218 (mmm-word-other-regions)
219 (fill-paragraph justify)))
220 (mmm-undo-syntax-other-regions))))
222 (defun mmm-noweb-fill-named-chunk (&optional justify)
223 "Fill the region containing the named chunk."
226 (let* ((name (or (mmm-name-at) (symbol-name mmm-primary-mode)))
227 (list (cdr (assoc name (mmm-names-alist (point-min) (point-max))))))
228 (if (or (string= name (symbol-name mmm-primary-mode))
229 (string-match "^quote" name))
231 (mmm-word-other-regions)
234 (mmm-space-other-regions)
235 (indent-region (caar list) (cadar (last list)) nil)))
236 (mmm-undo-syntax-other-regions))))
238 (defun mmm-noweb-auto-fill-doc-chunk ()
239 "Replacement for `do-auto-fill'."
241 (mmm-noweb-narrow-to-doc-chunk)
242 (mmm-word-other-regions)
244 (mmm-undo-syntax-other-regions)))
246 (defun mmm-noweb-auto-fill-doc-mode ()
247 "Install the improved auto fill function, iff necessary."
248 (if auto-fill-function
249 (setq auto-fill-function 'mmm-noweb-auto-fill-doc-chunk)))
251 (defun mmm-noweb-auto-fill-code-mode ()
252 "Install the default auto fill function, iff necessary."
253 (if auto-fill-function
254 (setq auto-fill-function 'do-auto-fill)))
257 ;;{{{ Functions on named chunks
259 (defun mmm-noweb-complete-chunk ()
260 "Try to complete the chunk name."
264 (if (re-search-backward "<<"
272 (let* ((pattern (buffer-substring beg end))
273 (alist (mmm-names-alist (point-min) (point-max)))
274 (completion (try-completion pattern alist)))
275 (cond ((eq completion t))
277 (message "Can't find completion for \"%s\"" pattern)
279 ((not (string= pattern completion))
280 (delete-region beg end)
282 (if (not (looking-at ">>"))
285 (message "Making completion list...")
286 (with-output-to-temp-buffer "*Completions*"
287 (display-completion-list
288 (all-completions pattern alist)))
289 (message "Making completion list...%s" "done"))))
290 (message "Not at chunk name..."))))
292 (defvar mmm-noweb-chunk-history nil
293 "History for `mmm-noweb-goto-chunk'.")
295 (defun mmm-noweb-goto-chunk ()
296 "Goto the named chunk."
299 (let* ((completion-ignore-case t)
300 (alist (mmm-names-alist (point-min) (point-max)))
301 (chunk (completing-read
302 "Chunk: " alist nil t
303 (mmm-name-at (point))
304 mmm-noweb-chunk-history)))
305 (goto-char (caadr (assoc chunk alist)))))
307 (defun mmm-noweb-goto-next (&optional cnt)
308 "Goto the continuation of the current chunk."
311 (let ((name (mmm-name-at (point))))
313 (let ((list (cdr (assoc name (mmm-names-alist
314 (overlay-end mmm-current-overlay)
317 (goto-char (caar (nthcdr (1- cnt) list))))))))
319 (defun mmm-noweb-goto-previous (&optional cnt)
320 "Goto the continuation of the current chunk."
323 (let ((name (mmm-name-at (point))))
327 (mmm-names-alist (point-min)
329 mmm-current-overlay)))))))
331 (goto-char (cadar (nthcdr cnt list))))))))
336 (defvar mmm-noweb-map (make-sparse-keymap))
337 (defvar mmm-noweb-prefix-map (make-sparse-keymap))
338 (define-key mmm-noweb-map mmm-mode-prefix-key mmm-noweb-prefix-map)
340 (mmm-define-key ?d 'mmm-noweb-narrow-to-doc-chunk mmm-noweb-prefix-map)
341 (mmm-define-key ?n 'mmm-noweb-goto-next mmm-noweb-prefix-map)
342 (mmm-define-key ?p 'mmm-noweb-goto-previous mmm-noweb-prefix-map)
343 (mmm-define-key ?q 'mmm-noweb-fill-chunk mmm-noweb-prefix-map)
344 ;; Cannot use C-g as goto command, so use C-s.
345 (mmm-define-key ?s 'mmm-noweb-goto-chunk mmm-noweb-prefix-map)
347 (define-key mmm-noweb-prefix-map "\t" 'mmm-noweb-complete-chunk)
349 ;; Don't want to add to either the mmm mode map (used in other mmm
350 ;; buffers) or the local map (used in other major mode buffers), so we
351 ;; make a full-buffer spanning overlay and add the map there.
352 (defun mmm-noweb-bind-keys ()
355 (let ((ovl (make-overlay (point-min) (point-max) nil nil t)))
356 ;; 'keymap', not 'local-map'
357 (overlay-put ovl 'keymap mmm-noweb-map))))
359 (add-hook 'mmm-noweb-class-hook 'mmm-noweb-bind-keys)
361 ;; TODO: make this overlay go away if mmm is turned off
365 ;; These functions below living here temporarily until a real place is
368 (defun mmm-syntax-region-list (syntax regions)
369 "Apply SYNTAX to a list of REGIONS of the form (BEG END).
370 If SYNTAX is not nil, set the syntax-table property of each region.
371 If SYNTAX is nil, remove the region syntax-table property.
372 See `mmm-syntax-region'."
373 (mapcar #'(lambda (reg)
374 (mmm-syntax-region (car reg) (cadr reg) syntax))
377 (defun mmm-syntax-other-regions (syntax &optional name)
378 "Apply SYNTAX cell to other regions.
379 Regions are separated by name, using either `mmm-name-at' or the
380 optional NAME to determine the current region name."
382 (setq name (or (mmm-name-at)
383 (symbol-name mmm-primary-mode))))
384 (mapcar #'(lambda (reg)
385 (if (not (string= (car reg) name))
386 (mmm-syntax-region-list syntax (cdr reg))))
387 (mmm-names-alist (point-min) (point-max))))
389 (defun mmm-word-other-regions ()
390 "Give all other regions word syntax."
392 (mmm-syntax-other-regions '(2 . 0))
393 (setq parse-sexp-lookup-properties t))
395 (defun mmm-space-other-regions ()
396 "Give all other regions space syntax."
398 (mmm-syntax-other-regions '(0 . 0))
399 (setq parse-sexp-lookup-properties t))
401 (defun mmm-undo-syntax-other-regions ()
402 "Remove syntax-table property from other regions."
404 (mmm-syntax-other-regions nil)
405 (setq parse-sexp-lookup-properties nil))
410 ;;; mmm-noweb.el ends here