cgit.sxemacs.org Git - packages/blob - xemacs-packages/mmm-mode/mmm-noweb.el

   1 ;;; mmm-noweb.el --- MMM submode class for Noweb programs
   2 ;;
   3 ;; Copyright 2003, 2004 Joe Kelsey <joe@zircon.seattle.wa.us>
   4 ;;
   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>
  10 ;;
  11
  12 ;;{{{ GPL
  13
  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)
  17 ;; any later version.
  18
  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.
  23
  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.
  28
  29 ;;}}}
  30
  31 ;;; Commentary:
  32
  33 ;; This file contains the definition of an MMM Mode submode class for
  34 ;; editing Noweb programs.
  35
  36 ;;; Code:
  37
  38 (require 'mmm-region)
  39 (require 'mmm-vars)
  40 (require 'mmm-mode)
  41
  42 ;;{{{ Variables
  43
  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.")
  49
  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.")
  53
  54 (defvar mmm-noweb-quote-string "quote"
  55   "*String used to form quoted code submode region names.
  56 See `mmm-noweb-quote'.")
  57
  58 (defvar mmm-noweb-quote-number 0
  59   "*Starting value appended to `mmm-noweb-quote-string'.
  60 See `mmm-noweb-quote'.")
  61
  62 (defvar mmm-noweb-narrowing nil
  63   "*Narrow the region to the current pair of chunks.")
  64
  65 ;;}}}
  66 ;;{{{ Support for mmm submode stuff
  67
  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)
  78                                   string
  79                                 (concat string "-mode")))))
  80         (or (mmm-ensure-modename modestr)
  81             mmm-noweb-code-mode))
  82     mmm-noweb-code-mode))
  83
  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
  87       mmm-noweb-code-mode))
  88
  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)))
  94
  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))
  99
 100 ;;}}}
 101 ;;{{{ mmm noweb submode group
 102
 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.
 112
 113 (mmm-add-group
 114  'noweb
 115  '((noweb-chunk
 116     :match-submode mmm-noweb-chunk
 117     :case-fold-search nil
 118     :front "^<<\\(.*\\)>>="
 119     :match-name "~1"
 120     :save-name 1
 121     :front-offset (end-of-line 1)
 122     :back "^@\\( \\|$\\|\\( %def .*$\\)\\)"
 123     :insert ((?c noweb-code "Code Chunk Name: "
 124                 "\n" @ "<<" str ">>=" @ "\n" _ "\n" @ "@ " @ "\n"))
 125     :skel-name t
 126     )
 127    (noweb-quote
 128     :match-submode mmm-noweb-quote
 129     :face mmm-special-submode-face
 130     :front "\\[\\["
 131 ;    :name-match mmm-noweb-quote-name
 132     :back "\\]\\]"
 133     :insert ((?q noweb-quote nil @ "[[" @ _ @ "]]" @))
 134     )
 135    ))
 136
 137 ;;}}}
 138 ;;{{{ Noweb regions
 139
 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)
 144          (regions
 145           (maplist #'(lambda (pos-list)
 146                        (if (cdr pos-list)
 147                            (if remove-next
 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) )
 152                                    (progn
 153                                      (setq remove-next t)
 154                                      nil)
 155                                  (list 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))))
 162
 163 ;;}}}
 164 ;;{{{ Filling, etc
 165
 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
 170 quoted code chunk."
 171   (interactive)
 172   (let ((name (mmm-name-at (point))))
 173     (if (or (null name) (string-match "^quote" name))
 174         (let ((prev (cond
 175                      ((= (point) (point-min)) (point))
 176                      (t (cadar (last (mmm-noweb-regions (point-min) (point)
 177                                                         "^quote"))))))
 178               (next (cond
 179                      ((= (point) (point-max)) (point))
 180                      (t (save-excursion
 181                           (goto-char (cadr
 182                                       (cadr (mmm-noweb-regions (point)
 183                                                                (point-max)
 184                                                                "^quote"))))
 185                           (forward-line -1)
 186                           (point))))))
 187           (narrow-to-region prev next)))))
 188
 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
 192 chunks."
 193   (interactive "P")
 194   (save-restriction
 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)
 198               (progn
 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))
 203         (progn
 204           (mmm-word-other-regions)
 205           (fill-paragraph justify)))
 206       (mmm-undo-syntax-other-regions))))
 207
 208 (defun mmm-noweb-fill-paragraph-chunk (&optional justify)
 209   "Fill a paragraph in the current chunk."
 210   (interactive "P")
 211   (save-restriction
 212     (let ((name (mmm-name-at (point))))
 213       (if (and name (not (string-match "^quote" name)))
 214           (progn
 215             (mmm-space-other-regions)
 216             (fill-paragraph justify))
 217         (progn
 218           (mmm-word-other-regions)
 219           (fill-paragraph justify)))
 220       (mmm-undo-syntax-other-regions))))
 221
 222 (defun mmm-noweb-fill-named-chunk (&optional justify)
 223   "Fill the region containing the named chunk."
 224   (interactive "P")
 225   (save-restriction
 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))
 230           (progn
 231             (mmm-word-other-regions)
 232             (do-auto-fill))
 233         (progn
 234           (mmm-space-other-regions)
 235           (indent-region (caar list) (cadar (last list)) nil)))
 236       (mmm-undo-syntax-other-regions))))
 237
 238 (defun mmm-noweb-auto-fill-doc-chunk ()
 239   "Replacement for `do-auto-fill'."
 240   (save-restriction
 241     (mmm-noweb-narrow-to-doc-chunk)
 242     (mmm-word-other-regions)
 243     (do-auto-fill)
 244     (mmm-undo-syntax-other-regions)))
 245
 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)))
 250
 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)))
 255
 256 ;;}}}
 257 ;;{{{ Functions on named chunks
 258
 259 (defun mmm-noweb-complete-chunk ()
 260   "Try to complete the chunk name."
 261   (interactive)
 262   (let ((end (point))
 263         (beg (save-excursion
 264                (if (re-search-backward "<<"
 265                                        (save-excursion
 266                                          (beginning-of-line)
 267                                          (point))
 268                                        t)
 269                    (match-end 0)
 270                  nil))))
 271         (if beg
 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))
 276                     ((null completion)
 277                      (message "Can't find completion for \"%s\"" pattern)
 278                      (ding))
 279                     ((not (string= pattern completion))
 280                      (delete-region beg end)
 281                      (insert completion)
 282                      (if (not (looking-at ">>"))
 283                          (insert ">>")))
 284                     (t
 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..."))))
 291
 292 (defvar mmm-noweb-chunk-history nil
 293   "History for `mmm-noweb-goto-chunk'.")
 294
 295 (defun mmm-noweb-goto-chunk ()
 296   "Goto the named chunk."
 297   (interactive)
 298   (widen)
 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)))))
 306
 307 (defun mmm-noweb-goto-next (&optional cnt)
 308   "Goto the continuation of the current chunk."
 309   (interactive "p")
 310   (widen)
 311   (let ((name (mmm-name-at (point))))
 312     (if name
 313         (let ((list (cdr (assoc name (mmm-names-alist
 314                                       (overlay-end mmm-current-overlay)
 315                                       (point-max))))))
 316           (if list
 317               (goto-char (caar (nthcdr (1- cnt) list))))))))
 318
 319 (defun mmm-noweb-goto-previous (&optional cnt)
 320   "Goto the continuation of the current chunk."
 321   (interactive "p")
 322   (widen)
 323   (let ((name (mmm-name-at (point))))
 324     (if name
 325         (let ((list (reverse
 326                      (cdr (assoc name
 327                                  (mmm-names-alist (point-min)
 328                                                   (overlay-start
 329                                                    mmm-current-overlay)))))))
 330           (if list
 331               (goto-char (cadar (nthcdr cnt list))))))))
 332
 333 ;;}}}
 334 ;;{{{ Key mappings
 335
 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)
 339
 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)
 346
 347 (define-key mmm-noweb-prefix-map "\t" 'mmm-noweb-complete-chunk)
 348
 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 ()
 353   (save-restriction
 354     (widen)
 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))))
 358
 359 (add-hook 'mmm-noweb-class-hook 'mmm-noweb-bind-keys)
 360
 361 ;; TODO: make this overlay go away if mmm is turned off
 362
 363 ;;}}}
 364
 365 ;; These functions below living here temporarily until a real place is
 366 ;; found.
 367
 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))
 375           regions))
 376
 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."
 381   (if (null 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))))
 388
 389 (defun mmm-word-other-regions ()
 390   "Give all other regions word syntax."
 391   (interactive)
 392   (mmm-syntax-other-regions '(2 . 0))
 393   (setq parse-sexp-lookup-properties t))
 394
 395 (defun mmm-space-other-regions ()
 396   "Give all other regions space syntax."
 397   (interactive)
 398   (mmm-syntax-other-regions '(0 . 0))
 399   (setq parse-sexp-lookup-properties t))
 400
 401 (defun mmm-undo-syntax-other-regions ()
 402   "Remove syntax-table property from other regions."
 403   (interactive)
 404   (mmm-syntax-other-regions nil)
 405   (setq parse-sexp-lookup-properties nil))
 406
 407
 408 (provide 'mmm-noweb)
 409
 410 ;;; mmm-noweb.el ends here