lisp/progmodes/hideshow.el

   1 ;;; hideshow.el --- minor mode cmds to selectively display blocks of code
   2
   3 ;; Copyright (C) 1994,1995 Free Software Foundation
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@netcom.com>
   6 ;; Version: 3.4
   7 ;; Keywords: C C++ lisp tools editing
   8 ;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;; LCD Archive Entry:
  28 ;; hideshow|Thien-Thi Nguyen|ttn@netcom.com|
  29 ;; minor mode commands to selectively display blocks of code|
  30 ;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z|
  31
  32 ;;; Commentary:
  33
  34 ;; This file provides `hs-minor-mode'.  When active, six commands:
  35 ;;   hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode
  36 ;; are available.  They implement block hiding and showing.  Blocks are
  37 ;; defined in mode-specific way.  In c-mode or c++-mode, they are simply
  38 ;; curly braces, while in lisp-ish modes they are parens.  Multi-line
  39 ;; comments (c-mode) can also be hidden.  The command M-x hs-minor-mode
  40 ;; toggles the minor mode or sets it (similar to outline minor mode).
  41 ;; See documentation for each command for more info.
  42 ;;
  43 ;; The variable `hs-unbalance-handler-method' controls hideshow's behavior
  44 ;; in the case of "unbalanced parentheses".  See doc for more info.
  45
  46 ;; Suggested usage:
  47
  48 ;; (load-library "hideshow")
  49 ;; (defun my-hs-setup () "enables hideshow and binds some commands"
  50 ;;   (hs-minor-mode 1)
  51 ;;   (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block)
  52 ;;   (define-key hs-minor-mode-map "\C-cs" 'hs-show-block)
  53 ;;   (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all)
  54 ;;   (define-key hs-minro-mode-map "\C-cS" 'hs-show-all)
  55 ;;   (define-key hs-minor-mode-map "\C-cR" 'hs-show-region))
  56 ;; (add-hook 'X-mode-hook 'my-hs-setup t)   ; other modes similarly
  57 ;;
  58 ;; where X = {emacs-lisp,c,c++,perl,...}.  See the doc for the variable
  59 ;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes.
  60
  61 ;; Etc:
  62
  63 ;; Bug reports and fixes welcome (comments, too).  Thanks go to
  64 ;;      Dean Andrews <adahome@ix.netcom.com>
  65 ;;      Preston F. Crow <preston.f.crow@dartmouth.edu>
  66 ;;      Gael Marziou <gael@gnlab030.grenoble.hp.com>
  67 ;;      Keith Sheffield <sheff@edcsgw2.cr.usgs.gov>
  68 ;;      Jan Djarv <jan.djarv@sa.erisoft.se>
  69 ;;      Lars Lindberg <qhslali@aom.ericsson.se>
  70 ;;      Alf-Ivar Holm <alfh@ifi.uio.no>
  71 ;; for valuable feedback, code and bug reports.
  72
  73 ;;; Code:
  74
  75
  76 ;;;----------------------------------------------------------------------------
  77 ;;; user-configurable variables
  78
  79 (defvar hs-unbalance-handler-method 'top-level
  80   "*Symbol representing how \"unbalanced parentheses\" should be handled.
  81 This error is usually signaled by `hs-show-block'.  One of four values:
  82 `top-level', `next-line', `signal' or `ignore'.  Default is `top-level'.
  83
  84 - `top-level' -- Show top-level block containing the currently troublesome
  85                  block.
  86 - `next-line' -- Use the fact that, for an already hidden block, its end
  87                  will be on the next line.  Attempt to show this block.
  88 - `signal' -- Pass the error through, stopping execution.
  89 - `ignore' -- Ignore the error, continuing execution.
  90
  91 Values other than these four will be interpreted as `signal'.")
  92
  93 (defvar hs-special-modes-alist '((c-mode "{" "}")
  94                                  (c++-mode "{" "}"))
  95   "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC).
  96 If present, hideshow will use these values for the start and end regexps,
  97 respectively.  Since Algol-ish languages do not have single-character
  98 block delimiters, the function `forward-sexp' which is used by hideshow
  99 doesn't work.  In this case, if a similar function is provided, you can
 100 register it and have hideshow use it instead of `forward-sexp'.  To add
 101 more values, use
 102
 103 \t(pushnew '(new-mode st-re end-re function-name)
 104 \t      hs-special-modes-alist :test 'equal)
 105
 106 For example:
 107
 108 \t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement)
 109 \t      hs-special-modes-alist :test 'equal)
 110
 111 Note that the regexps should not contain leading or trailing whitespace.")
 112
 113 (defvar hs-hide-hook nil
 114   "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'.")
 115
 116 (defvar hs-show-hook nil
 117   "*Hooks called at the end of commands to show text.
 118 These commands include `hs-show-all', `hs-show-block' and `hs-show-region'.")
 119
 120 (defvar hs-minor-mode-prefix "\C-c"
 121   "*Prefix key to use for hideshow commands in hideshow minor mode.")
 122
 123
 124 ;;;----------------------------------------------------------------------------
 125 ;;; internal variables
 126
 127 (defvar hs-minor-mode nil
 128   "Non-nil if using hideshow mode as a minor mode of some other mode.
 129 Use the command `hs-minor-mode' to toggle this variable.")
 130
 131 (defvar hs-minor-mode-map nil
 132   "Mode map for hideshow minor mode.")
 133
 134 (defvar hs-menu-bar nil
 135   "Menu bar for hideshow minor mode (Xemacs only).")
 136
 137 (defvar hs-c-start-regexp nil
 138   "Regexp for beginning of comments.  Buffer-local.
 139 Differs from mode-specific comment regexps in that surrounding
 140 whitespace is stripped.")
 141
 142 (defvar hs-c-end-regexp nil
 143   "Regexp for end of comments.  Buffer-local.
 144 See `hs-c-start-regexp'.")
 145
 146 (defvar hs-block-start-regexp nil
 147   "Regexp for beginning of block.  Buffer-local.")
 148
 149 (defvar hs-block-end-regexp nil
 150   "Regexp for end of block.  Buffer-local.")
 151
 152 (defvar hs-forward-sexp-func 'forward-sexp
 153   "Function used to do a forward-sexp.  Should change for Algol-ish modes.
 154 For single-character block delimiters -- ie, the syntax table regexp for the
 155 character is either `(' or `)' -- `hs-forward-sexp-func' would just be
 156 `forward-sexp'.  For other modes such as simula, a more specialized function
 157 is necessary.")
 158
 159 (defvar hs-emacs-type 'fsf
 160   "Used to support both FSF Emacs and Xemacs.")
 161
 162 (eval-when-compile
 163   (if (string-match "xemacs\\|lucid" emacs-version)
 164       (progn
 165         (defvar current-menubar nil "")
 166         (defun set-buffer-menubar (arg1))
 167         (defun add-menu (arg1 arg2 arg3)))))
 168
 169
 170 ;;;----------------------------------------------------------------------------
 171 ;;; support funcs
 172
 173 ;; snarfed from outline.el, but added buffer-read-only
 174 (defun hs-flag-region (from to flag)
 175   "Hides or shows lines from FROM to TO, according to FLAG.
 176 If FLAG is `?\\n' (the newline character) then show the text;
 177 if FLAG is `?\\^M' \(control-M) then hide the text."
 178   (let ((modp (buffer-modified-p))
 179         buffer-read-only)               ; nothing is immune
 180     (unwind-protect (progn
 181                       (subst-char-in-region
 182                        from to
 183                        (if (= flag ?\n) ?\C-m ?\n)
 184                        flag t))
 185       (set-buffer-modified-p modp))))
 186
 187 (defun hs-hide-block-at-point (&optional end)
 188   "Hide block iff on block beginning, optional END means reposition at end."
 189   (if (looking-at hs-block-start-regexp)
 190       (let* ((p (point))
 191              (q (progn (funcall hs-forward-sexp-func 1) (point))))
 192         (forward-line -1) (end-of-line)
 193         (if (and (< p (point)) (> (count-lines p q) 1))
 194             (hs-flag-region p (point) ?\C-m))
 195         (goto-char (if end q p)))))
 196
 197 (defun hs-show-block-at-point (&optional end)
 198   "Show block iff on block beginning.  Optional END means reposition at end."
 199   (if (looking-at hs-block-start-regexp)
 200       (let* ((p (point))
 201              (q
 202               (condition-case error     ; probably unbalanced paren
 203                   (progn
 204                     (funcall hs-forward-sexp-func 1)
 205                     (point))
 206                 (error
 207                  (cond
 208                   ((eq hs-unbalance-handler-method 'ignore)
 209                    ;; just ignore this block
 210                    (point))
 211                   ((eq hs-unbalance-handler-method 'top-level)
 212                    ;; try to get out of rat's nest and expose the whole func
 213                    (if (/= (current-column) 0) (beginning-of-defun))
 214                    (setq p (point))
 215                    (re-search-forward (concat "^" hs-block-start-regexp)
 216                                       (point-max) t 2)
 217                    (point))
 218                   ((eq hs-unbalance-handler-method 'next-line)
 219                    ;; assumption is that user knows what s/he's doing
 220                    (beginning-of-line) (setq p (point))
 221                    (end-of-line 2) (point))
 222                   (t
 223                    ;; pass error through -- this applies to `signal', too
 224                    (signal (car error) (cdr error))))))))
 225         (hs-flag-region p q ?\n)
 226         (goto-char (if end (1+ (point)) p)))))
 227
 228 (defun hs-safety-is-job-n ()
 229   "Warn if `selective-display' or `selective-display-ellipses' is nil."
 230   (let ((str ""))
 231     (or selective-display
 232         (setq str "selective-display nil "))
 233     (or selective-display-ellipses
 234         (setq str (concat str "selective-display-ellipses nil")))
 235     (if (= (length str) 0)
 236         nil
 237       (message "warning: %s" str)
 238       (sit-for 2))))
 239
 240 (defun hs-inside-comment-p ()
 241   "Returns non-nil if point is inside a comment, otherwise nil.
 242 Actually, for multi-line-able comments, returns a list containing
 243 the buffer position of the start and the end of the comment."
 244   ;; is it single-line-only or multi-line-able?
 245   (save-excursion
 246     (let ((p (point))
 247           q)
 248       (if (string= comment-end "")      ; single line
 249           (let (found)
 250             (beginning-of-line)
 251             (setq found (re-search-forward hs-c-start-regexp p t))
 252             (and found (not (search-forward "\"" p t))))
 253         (re-search-forward hs-c-end-regexp (point-max) 1)
 254         (setq q (point))
 255         (forward-comment -1)
 256         (re-search-forward hs-c-start-regexp (point-max) 1)
 257         (if (< (- (point) (length comment-start)) p)
 258             (list (match-beginning 0) q))))))
 259
 260 (defun hs-grok-mode-type ()
 261   "Setup variables for new buffers where applicable."
 262   (if (and (boundp 'comment-start)
 263            (boundp 'comment-end))
 264       (progn
 265         (setq hs-c-start-regexp (regexp-quote comment-start))
 266         (if (string-match " +$" hs-c-start-regexp)
 267             (setq hs-c-start-regexp
 268                   (substring hs-c-start-regexp 0 (1- (match-end 0)))))
 269         (setq hs-c-end-regexp (if (string= "" comment-end) "\n"
 270                                 (regexp-quote comment-end)))
 271         (if (string-match "^ +" hs-c-end-regexp)
 272             (setq hs-c-end-regexp
 273                   (substring hs-c-end-regexp (match-end 0))))
 274         (let ((lookup (assoc major-mode hs-special-modes-alist)))
 275           (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(")
 276                 hs-block-end-regexp (or (nth 2 lookup) "\\s\)")
 277                 hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp))))))
 278
 279 (defun hs-find-block-beginning ()
 280   "Repositions point at block-start.  Return point, or nil if top-level."
 281   (let (done
 282         (here (point))
 283         (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\("
 284                               hs-block-end-regexp "\\)")))
 285     (while (and (not done)
 286                 (re-search-backward both-regexps (point-min) t))
 287       (if (match-beginning 1)           ; start of start-regexp
 288           (setq done (match-beginning 1))
 289         (goto-char (match-end 2))       ; end of end-regexp
 290         (funcall hs-forward-sexp-func -1)))
 291     (goto-char (or done here))
 292     done))
 293
 294 (defmacro hs-life-goes-on (&rest body)
 295   "Executes optional BODY iff variable `hs-minor-mode' is non-nil."
 296   (list 'if 'hs-minor-mode (cons 'progn body)))
 297
 298
 299 ;;;----------------------------------------------------------------------------
 300 ;;; commands
 301
 302 ;;;###autoload
 303 (defun hs-hide-all ()
 304   "Hides all top-level blocks, displaying only first and last lines.
 305 It moves point to the beginning of the line, and it runs the normal hook
 306 `hs-hide-hook'.  See documentation for `run-hooks'."
 307   (interactive)
 308   (hs-life-goes-on
 309    (message "hiding all blocks ...")
 310    (save-excursion
 311      (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness
 312      (goto-char (point-min))
 313      (let ((count 0)
 314            (top-level-re (concat "^" hs-block-start-regexp)))
 315        (while (progn
 316                 (forward-comment (buffer-size))
 317                 (re-search-forward top-level-re (point-max) t))
 318          (goto-char (match-beginning 0))
 319          (hs-hide-block-at-point t)
 320          (message "hiding ... %d" (setq count (1+ count)))))
 321      (hs-safety-is-job-n))
 322    (beginning-of-line)
 323    (message "hiding all blocks ... done")
 324    (run-hooks 'hs-hide-hook)))
 325
 326 (defun hs-show-all ()
 327   "Shows all top-level blocks.
 328 This does not change point; it runs the normal hook `hs-show-hook'.
 329 See documentation for `run-hooks'."
 330   (interactive)
 331   (hs-life-goes-on
 332    (message "showing all blocks ...")
 333    (hs-flag-region (point-min) (point-max) ?\n)
 334    (message "showing all blocks ... done")
 335    (run-hooks 'hs-show-hook)))
 336
 337 ;;;###autoload
 338 (defun hs-hide-block (&optional end)
 339   "Selects a block and hides it.  With prefix arg, reposition at end.
 340 Block is defined as a sexp for lispish modes, mode-specific otherwise.
 341 Comments are blocks, too.  Upon completion, point is at repositioned and
 342 the normal hook `hs-hide-hook' is run.  See documentation for `run-hooks'."
 343   (interactive "P")
 344   (hs-life-goes-on
 345    (let ((c-reg (hs-inside-comment-p)))
 346      (if c-reg
 347          (cond ((string= comment-end "")
 348                 (message "can't hide a single-line comment"))
 349                ((< (count-lines (car c-reg) (nth 1 c-reg)) 2)
 350                 (message "not enough comment lines to hide"))
 351                (t
 352                 (goto-char (nth 1 c-reg))
 353                 (forward-line -1)
 354                 (hs-flag-region (car c-reg) (point) ?\C-m)
 355                 (goto-char (if end (nth 1 c-reg) (car c-reg)))
 356                 (hs-safety-is-job-n)
 357                 (run-hooks 'hs-hide-hook)))
 358        (if (or (looking-at hs-block-start-regexp)
 359                (hs-find-block-beginning))
 360            (progn
 361              (hs-hide-block-at-point end)
 362              (hs-safety-is-job-n)
 363              (run-hooks 'hs-hide-hook)))))))
 364
 365 (defun hs-show-block (&optional end)
 366   "Selects a block and shows it.  With prefix arg, reposition at end.
 367 Upon completion, point is repositioned and the normal hook
 368 `hs-show-hook' is run.  See documentation for `hs-hide-block' and `run-hooks'."
 369   (interactive "P")
 370   (hs-life-goes-on
 371    (let ((c-reg (hs-inside-comment-p)))
 372      (if c-reg
 373          (cond ((string= comment-end "")
 374                 (message "already looking at the entire comment"))
 375                (t
 376                 (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n)
 377                 (goto-char (if end (nth 1 c-reg) (car c-reg)))))
 378        (if (or (looking-at hs-block-start-regexp)
 379                (hs-find-block-beginning))
 380            (progn
 381              (hs-show-block-at-point end)
 382              (hs-safety-is-job-n)
 383              (run-hooks 'hs-show-hook)))))))
 384
 385 (defun hs-show-region (beg end)
 386   "Shows all lines from BEG to END, without doing any block analysis.
 387 Note:` hs-show-region' is intended for use when when `hs-show-block' signals
 388 `unbalanced parentheses' and so is an emergency measure only.  You may
 389 become very confused if you use this command indiscriminately."
 390   (interactive "r")
 391   (hs-life-goes-on
 392    (hs-flag-region beg end ?\n)
 393    (hs-safety-is-job-n)
 394    (run-hooks 'hs-show-hook)))
 395
 396 ;;;###autoload
 397 (defun hs-minor-mode (&optional arg)
 398   "Toggle hideshow minor mode.
 399 With ARG, turn hideshow minor mode on if ARG is positive, off otherwise.
 400 When hideshow minor mode is on, the menu bar is augmented with hideshow
 401 commands and the hideshow commands are enabled.  The variables
 402 `selective-display' and `selective-display-ellipses' are set to t.
 403 Last, the normal hook `hs-minor-mode-hook' is run; see the doc for `run-hooks'.
 404
 405 Turning hideshow minor mode off reverts the menu bar and the
 406 variables to default values and disables the hideshow commands."
 407   (interactive "P")
 408   (setq hs-minor-mode
 409         (if (null arg)
 410             (not hs-minor-mode)
 411           (> (prefix-numeric-value arg) 0)))
 412   (if hs-minor-mode
 413       (progn
 414         (if (eq hs-emacs-type 'lucid)
 415             (progn
 416               (set-buffer-menubar (copy-sequence current-menubar))
 417               (add-menu nil (car hs-menu-bar) (cdr hs-menu-bar))))
 418         (setq selective-display t
 419               selective-display-ellipses t)
 420         (hs-grok-mode-type)
 421         (run-hooks 'hs-minor-mode-hook))
 422     (if (eq hs-emacs-type 'lucid)
 423         (set-buffer-menubar (delete hs-menu-bar current-menubar)))
 424     (kill-local-variable 'selective-display)
 425     (kill-local-variable 'selective-display-ellipses)))
 426
 427
 428 ;;;----------------------------------------------------------------------------
 429 ;;; load-time setup routines
 430
 431 ;; which emacs being used?
 432 (setq hs-emacs-type
 433       (if (string-match "xemacs\\|lucid" emacs-version)
 434           'lucid
 435         'fsf))
 436
 437 ;; keymaps and menus
 438 (if (not hs-minor-mode-map)
 439     (setq hs-minor-mode-map (make-sparse-keymap))
 440   (cond
 441    ((eq hs-emacs-type 'lucid)
 442     (setq hs-menu-bar                   ; build top down for lucid
 443           '("hideshow"
 444             ["Hide Block" hs-hide-block t]
 445             ["Show Block" hs-show-block t]
 446             ["Hide All" hs-hide-all t]
 447             ["Show All" hs-show-all t]
 448             ["Show Region" hs-show-region t])))
 449    (t                                   ; build bottom up for others
 450     (define-key hs-minor-mode-map [menu-bar hideshow]
 451       (cons "hideshow" (make-sparse-keymap "hideshow")))
 452     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-region]
 453       '("Show Region" . hs-show-region))
 454     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-all]
 455       '("Show All" . hs-show-all))
 456     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-all]
 457       '("Hide All" . hs-hide-all))
 458     (define-key hs-minor-mode-map [menu-bar hideshow hs-show-block]
 459       '("Show Block" . hs-show-block))
 460     (define-key hs-minor-mode-map [menu-bar hideshow hs-hide-block]
 461       '("Hide Block" . hs-hide-block)))))
 462
 463 ;; some housekeeping
 464 (or (assq 'hs-minor-mode minor-mode-map-alist)
 465     (setq minor-mode-map-alist
 466           (cons (cons 'hs-minor-mode hs-minor-mode-map)
 467                 minor-mode-map-alist)))
 468 (or (assq 'hs-minor-mode minor-mode-alist)
 469     (setq minor-mode-alist (append minor-mode-alist
 470                                    (list '(hs-minor-mode " hs")))))
 471
 472 ;; make some variables buffer-local
 473 (make-variable-buffer-local 'hs-minor-mode)
 474 (make-variable-buffer-local 'hs-c-start-regexp)
 475 (make-variable-buffer-local 'hs-c-end-regexp)
 476 (make-variable-buffer-local 'hs-block-start-regexp)
 477 (make-variable-buffer-local 'hs-block-end-regexp)
 478 (make-variable-buffer-local 'hs-forward-sexp-func)
 479 (put 'hs-minor-mode 'permanent-local t)
 480 (put 'hs-c-start-regexp 'permanent-local t)
 481 (put 'hs-c-end-regexp 'permanent-local t)
 482 (put 'hs-block-start-regexp 'permanent-local t)
 483 (put 'hs-block-end-regexp 'permanent-local t)
 484 (put 'hs-forward-sexp-func 'permanent-local t)
 485
 486
 487 ;;;----------------------------------------------------------------------------
 488 ;;; that's it
 489
 490 (provide 'hideshow)
 491
 492 ;;; hideshow.el ends here