Source

mmm-mode / mmm-noweb.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
;;; mmm-noweb.el --- MMM submode class for Noweb programs
;;
;; Copyright 2003, 2004 Joe Kelsey <joe@zircon.seattle.wa.us>
;;
;; The filling, completion and chunk motion commands either taken
;; directly from or inspired by code in:
;; noweb-mode.el - edit noweb files with GNU Emacs
;; Copyright 1995 by Thorsten.Ohl @ Physik.TH-Darmstadt.de
;;     with a little help from Norman Ramsey <norman@bellcore.com>
;; 

;;{{{ GPL

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;}}}

;;; Commentary:

;; This file contains the definition of an MMM Mode submode class for
;; editing Noweb programs.

;;; Code:

(require 'mmm-region)
(require 'mmm-vars)
(require 'mmm-mode)

;;{{{ Variables

(defvar mmm-noweb-code-mode 'fundamental-mode
  "*Major mode for editing code chunks.
This is set to FUNDAMENTAL-MODE by default, but you might want to change
this in the Local Variables section of your file to something more
appropriate, like C-MODE, FORTRAN-MODE, or even INDENTED-TEXT-MODE.")

(defvar mmm-noweb-quote-mode nil
  "*Major mode for quoted code chunks within documentation chunks.
If nil, defaults to `mmm-noweb-code-mode', which see.")

(defvar mmm-noweb-quote-string "quote"
  "*String used to form quoted code submode region names.
See `mmm-noweb-quote'.")

(defvar mmm-noweb-quote-number 0
  "*Starting value appended to `mmm-noweb-quote-string'.
See `mmm-noweb-quote'.")

(defvar mmm-noweb-narrowing nil
  "*Narrow the region to the current pair of chunks.")

;;}}}
;;{{{ Support for mmm submode stuff

(defun mmm-noweb-chunk (form)
  "Return the noweb code mode chosen by the user.
If the next 100 characters of the buffer contain a string of the form
\"-*- MODE -*-\", then return MODE as the chosen mode, otherwise
return the value of `mmm-noweb-code-mode'."
  ;; Look for -*- mode -*- in the first two lines.
  ;; 120 chars = 40 chars for #! + 80 chars for following line...
  (if (re-search-forward "-\\*-\\s +\\(\\S-+\\)\\s +-\\*-" (+ (point) 120) t)
      (let* ((string (match-string-no-properties 1))
	     (modestr (intern (if (string-match "mode\\'" string)
				  string
				(concat string "-mode")))))
	(or (mmm-ensure-modename modestr)
	    mmm-noweb-code-mode))
    mmm-noweb-code-mode))

(defun mmm-noweb-quote (form)
  "Create a unique name for a quoted code region within a documentation chunk."
  (or mmm-noweb-quote-mode
      mmm-noweb-code-mode))

(defun mmm-noweb-quote-name (form)
  "Create a unique name for a quoted code region within a documentation chunk."
  (setq mmm-noweb-quote-number (1+ mmm-noweb-quote-number))
  (concat mmm-noweb-quote-string "-"
	  (number-to-string mmm-noweb-quote-number)))

(defun mmm-noweb-chunk-name (form)
  "Get the chunk name from FRONT-FORM."
  (string-match "<<\\(.*\\)>>=" form)
  (match-string-no-properties 1 form))

;;}}}
;;{{{ mmm noweb submode group

;; We assume that the global document mode is latex or whatever, the
;; user wants.  This class controls the code chunk submodes.  We use
;; match-submode to either return the value in mmm-noweb-code-mode or to
;; look at the first line of the chunk for a submode setting.  We reset
;; case-fold-search because chunk names are case sensitive.  The front
;; string identifies the chunk name between the <<>>.  Since this is
;; done, name-match can use the same functions as save-matches for back.
;; Our insert skeleton places a new code chunk and the skel-name lets us
;; optimize the skelton naming to use the inserted string.

(mmm-add-group
 'noweb
 '((noweb-chunk
    :match-submode mmm-noweb-chunk
    :case-fold-search nil
    :front "^<<\\(.*\\)>>="
    :match-name "~1"
    :save-name 1
    :front-offset (end-of-line 1)
    :back "^@\\( \\|$\\|\\( %def .*$\\)\\)"
    :insert ((?c noweb-code "Code Chunk Name: "
		"\n" @ "<<" str ">>=" @ "\n" _ "\n" @ "@ " @ "\n"))
    :skel-name t
    )
   (noweb-quote
    :match-submode mmm-noweb-quote
    :face mmm-special-submode-face
    :front "\\[\\["
;    :name-match mmm-noweb-quote-name
    :back "\\]\\]"
    :insert ((?q noweb-quote nil @ "[[" @ _ @ "]]" @))
    )
   ))

;;}}}
;;{{{ Noweb regions

(defun mmm-noweb-regions (start stop regexp &optional delim)
  "Return a liat of regions of the form \(NAME BEG END) that exclude
names which match REGEXP."
  (let* ((remove-next nil)
	 (regions
	  (maplist #'(lambda (pos-list)
		       (if (cdr pos-list)
			   (if remove-next
			       (setq remove-next nil)
			     (let ((name (or (mmm-name-at (car pos-list) 'beg)
					     (symbol-name mmm-primary-mode))))
			       (if (and regexp (string-match regexp name) )
				   (progn
				     (setq remove-next t)
				     nil)
				 (list name
				       (car pos-list) (cadr pos-list)))))))
		   (mmm-submode-changes-in start stop t delim))))
    ;; The above loop leaves lots of nils in the list...
    ;; Removing them saves us from having to do the (last x 2)
    ;; trick that mmm-regions-in does.
    (setq regions (delq nil regions))))

;;}}}
;;{{{ Filling, etc

(defun mmm-noweb-narrow-to-doc-chunk ()
  "Narrow to the current doc chunk.
The current chunk includes all quoted code chunks (i.e., \[\[...\]\]).
This function is only valid when called with point in a doc chunk or
quoted code chunk."
  (interactive)
  (let ((name (mmm-name-at (point))))
    (if (or (null name) (string-match "^quote" name))
	(let ((prev (cond
		     ((= (point) (point-min)) (point))
		     (t (cadar (last (mmm-noweb-regions (point-min) (point)
							"^quote"))))))
	      (next (cond
		     ((= (point) (point-max)) (point))
		     (t (save-excursion
			  (goto-char (cadr
				      (cadr (mmm-noweb-regions (point)
							       (point-max)
							       "^quote"))))
			  (forward-line -1)
			  (point))))))
	  (narrow-to-region prev next)))))

(defun mmm-noweb-fill-chunk (&optional justify)
  "Fill the current chunk according to mode.
Run `fill-region' on documentation chunks and `indent-region' on code
chunks."
  (interactive "P")
  (save-restriction
    (let ((name (mmm-name-at (point))))
      (if (and name (not (string-match "^quote" name)))
	  (if (or indent-region-function indent-line-function)
	      (progn
		(mmm-space-other-regions)
		(indent-region (overlay-start mmm-current-overlay)
			       (overlay-end mmm-current-overlay) nil))
	    (error "No indentation functions defined in %s!" major-mode))
	(progn
	  (mmm-word-other-regions)
	  (fill-paragraph justify)))
      (mmm-undo-syntax-other-regions))))

(defun mmm-noweb-fill-paragraph-chunk (&optional justify)
  "Fill a paragraph in the current chunk."
  (interactive "P")
  (save-restriction
    (let ((name (mmm-name-at (point))))
      (if (and name (not (string-match "^quote" name)))
	  (progn
	    (mmm-space-other-regions)
	    (fill-paragraph justify))
	(progn
	  (mmm-word-other-regions)
	  (fill-paragraph justify)))
      (mmm-undo-syntax-other-regions))))

(defun mmm-noweb-fill-named-chunk (&optional justify)
  "Fill the region containing the named chunk."
  (interactive "P")
  (save-restriction
    (let* ((name (or (mmm-name-at) (symbol-name mmm-primary-mode)))
	   (list (cdr (assoc name (mmm-names-alist (point-min) (point-max))))))
      (if (or (string= name (symbol-name mmm-primary-mode))
	      (string-match "^quote" name))
	  (progn
	    (mmm-word-other-regions)
	    (do-auto-fill))
	(progn
	  (mmm-space-other-regions)
	  (indent-region (caar list) (cadar (last list)) nil)))
      (mmm-undo-syntax-other-regions))))

(defun mmm-noweb-auto-fill-doc-chunk ()
  "Replacement for `do-auto-fill'."
  (save-restriction
    (mmm-noweb-narrow-to-doc-chunk)
    (mmm-word-other-regions)
    (do-auto-fill)
    (mmm-undo-syntax-other-regions)))

(defun mmm-noweb-auto-fill-doc-mode ()
  "Install the improved auto fill function, iff necessary."
  (if auto-fill-function
      (setq auto-fill-function 'mmm-noweb-auto-fill-doc-chunk)))

(defun mmm-noweb-auto-fill-code-mode ()
  "Install the default auto fill function, iff necessary."
  (if auto-fill-function
      (setq auto-fill-function 'do-auto-fill)))

;;}}}
;;{{{ Functions on named chunks

(defun mmm-noweb-complete-chunk ()
  "Try to complete the chunk name."
  (interactive)
  (let ((end (point))
	(beg (save-excursion
	       (if (re-search-backward "<<"
				       (save-excursion
					 (beginning-of-line)
					 (point))
				       t)
		   (match-end 0)
		 nil))))
	(if beg
	    (let* ((pattern (buffer-substring beg end))
		   (alist (mmm-names-alist (point-min) (point-max)))
		   (completion (try-completion pattern alist)))
	      (cond ((eq completion t))
		    ((null completion)
		     (message "Can't find completion for \"%s\"" pattern)
		     (ding))
		    ((not (string= pattern completion))
		     (delete-region beg end)
		     (insert completion)
		     (if (not (looking-at ">>"))
			 (insert ">>")))
		    (t
		     (message "Making completion list...")
		     (with-output-to-temp-buffer "*Completions*"
		       (display-completion-list
			(all-completions pattern alist)))
		     (message "Making completion list...%s" "done"))))
	  (message "Not at chunk name..."))))

(defvar mmm-noweb-chunk-history nil
  "History for `mmm-noweb-goto-chunk'.")

(defun mmm-noweb-goto-chunk ()
  "Goto the named chunk."
  (interactive)
  (widen)
  (let* ((completion-ignore-case t)
	 (alist (mmm-names-alist (point-min) (point-max)))
	 (chunk (completing-read
		 "Chunk: " alist nil t
		 (mmm-name-at (point))
		 mmm-noweb-chunk-history)))
    (goto-char (caadr (assoc chunk alist)))))

(defun mmm-noweb-goto-next (&optional cnt)
  "Goto the continuation of the current chunk."
  (interactive "p")
  (widen)
  (let ((name (mmm-name-at (point))))
    (if name
	(let ((list (cdr (assoc name (mmm-names-alist
				      (overlay-end mmm-current-overlay)
				      (point-max))))))
	  (if list
	      (goto-char (caar (nthcdr (1- cnt) list))))))))

(defun mmm-noweb-goto-previous (&optional cnt)
  "Goto the continuation of the current chunk."
  (interactive "p")
  (widen)
  (let ((name (mmm-name-at (point))))
    (if name
	(let ((list (reverse
		     (cdr (assoc name
				 (mmm-names-alist (point-min)
						  (overlay-start
						   mmm-current-overlay)))))))
	  (if list
	      (goto-char (cadar (nthcdr cnt list))))))))

;;}}}
;;{{{ Key mappings

(defvar mmm-noweb-map (make-sparse-keymap))
(defvar mmm-noweb-prefix-map (make-sparse-keymap))
(define-key mmm-noweb-map mmm-mode-prefix-key mmm-noweb-prefix-map)

(mmm-define-key ?d 'mmm-noweb-narrow-to-doc-chunk mmm-noweb-prefix-map)
(mmm-define-key ?n 'mmm-noweb-goto-next mmm-noweb-prefix-map)
(mmm-define-key ?p 'mmm-noweb-goto-previous mmm-noweb-prefix-map)
(mmm-define-key ?q 'mmm-noweb-fill-chunk mmm-noweb-prefix-map)
;; Cannot use C-g as goto command, so use C-s.
(mmm-define-key ?s 'mmm-noweb-goto-chunk mmm-noweb-prefix-map)

(define-key mmm-noweb-prefix-map "\t" 'mmm-noweb-complete-chunk)

;; Don't want to add to either the mmm mode map (used in other mmm
;; buffers) or the local map (used in other major mode buffers), so we
;; make a full-buffer spanning overlay and add the map there.
(defun mmm-noweb-bind-keys ()
  (save-restriction
    (widen)
    (let ((ovl (make-overlay (point-min) (point-max) nil nil t)))
      ;; 'keymap', not 'local-map'
      (overlay-put ovl 'keymap mmm-noweb-map))))

(add-hook 'mmm-noweb-class-hook 'mmm-noweb-bind-keys)

;; TODO: make this overlay go away if mmm is turned off

;;}}}

;; These functions below living here temporarily until a real place is
;; found.

(defun mmm-syntax-region-list (syntax regions)
  "Apply SYNTAX to a list of REGIONS of the form (BEG END).
If SYNTAX is not nil, set the syntax-table property of each region.
If SYNTAX is nil, remove the region syntax-table property.
See `mmm-syntax-region'."
  (mapcar #'(lambda (reg)
	      (mmm-syntax-region (car reg) (cadr reg) syntax))
	  regions))

(defun mmm-syntax-other-regions (syntax &optional name)
  "Apply SYNTAX cell to other regions.
Regions are separated by name, using either `mmm-name-at' or the
optional NAME to determine the current region name."
  (if (null name)
      (setq name (or (mmm-name-at)
		     (symbol-name mmm-primary-mode))))
  (mapcar #'(lambda (reg)
	      (if (not (string= (car reg) name))
		  (mmm-syntax-region-list syntax (cdr reg))))
	  (mmm-names-alist (point-min) (point-max))))

(defun mmm-word-other-regions ()
  "Give all other regions word syntax."
  (interactive)
  (mmm-syntax-other-regions '(2 . 0))
  (setq parse-sexp-lookup-properties t))

(defun mmm-space-other-regions ()
  "Give all other regions space syntax."
  (interactive)
  (mmm-syntax-other-regions '(0 . 0))
  (setq parse-sexp-lookup-properties t))

(defun mmm-undo-syntax-other-regions ()
  "Remove syntax-table property from other regions."
  (interactive)
  (mmm-syntax-other-regions nil)
  (setq parse-sexp-lookup-properties nil))


(provide 'mmm-noweb)

;;; mmm-noweb.el ends here